;; -*- Mode:LISP; Package:UA; Base:8 -*-
;;;     MICRO ASSEMBLER  FOR CADR

;TO COMPILE OR RUN ON THE LISP MACHINE, USE THE PACKAGE DEFINITION IN LCADR;UA PKG

(IF-FOR-LISPM           ;These not used here anymore, but needed to read in QCOM.
 (DEFMACRO LOGLDB (PTR VAL) `(LDB ,PTR ,VAL)))
(IF-FOR-LISPM
 (DEFMACRO LOGDPB (NEWVAL PTR VAL) `(DPB ,NEWVAL ,PTR ,VAL)))

;SYMBOLS IN CONS-LAP:
; A SYMBOL IN CONS-LAP HAS AS ITS VALUE A PROGRAM!
;  THE PROGRAM IS EVALUATED BY RECURSIVE CALLS TO CONS-LAP-EVAL.
;  IF THE ARGUMENT TO CONS-LAP-EVAL IS NUMERIC, IT IS RETURNED AS THE VALUE.
;  IF NIL, THIS SPECIFIES THE NULL VALUE.
;  IF A SYMBOL, ITS VALUE IS RUN AS A PROGRAM AND RETURNED.
;  IF A LIST, CAR OF THE LISP IS THE FUNCTION AND THE REST OF THE LIST
;   ARGUMENTS, LISP STYLE.  UNLESS OTHERWISE NOTED BELOW, ALL FUNCTIONS
;   EVALUATE THEIR ARGS (LISP STYLE) AND ACTUALLY DO SOMETHING ONLY
;   AFTER THE EVALUATION OF THEIR ARGUMENTS HAS FINISHED.

;AVAILABLE FUNCTIONS:
; FUNCTIONS OF ONE ARGUMENT
;  SPECIFERS OF LOCALITY: A-MEM, M-MEM, I-MEM, D-MEM.
;       RETURN VALUE INDICATING THAT THEIR ARGUMENT CORRESPONDS TO AN
;       ADDRESS IN THE SPECIFIED MEMORY.
;  CONDITIONALS:  DESTINATION-P, SOURCE-P, DISPATCH-INSTRUCTION-P, JUMP-INSTRUCTION-P
;       ALU-INSTRUCTION-P, BYTE-INSTRUCTION-P. EVALUATE AND RETURN ARGUMENT
;       ONLY IF SPECIFIED CONDITION TRUE (NAMELY: ASSEMBLING A DESTINATION FIELD,
;       A SOURCE FIELD, OR THE TYPE OF INSTRUCTION INDICATED). RETURN NIL
;       IF CONDITION FALSE.
;  NEGATION: NOT. MUST BE NESTED WITH ONE OF THE CONDITIONALS ABOVE AS IS
;       (NOT (DESTINATION (...))).
;  OR. RETURNS FIRST NON-NIL VALUE LIKE LISP OR.
;  PLUS. COMBINES THE VALUES / PROPERTIES REPRESENTED BY ALL ITS ARGUMENTS.
;       USED TO BE TWO ARGS ONLY, NOW TAKES ANY NUMBER OF ARGS.
;  DIFFERENCE.  LIKEWISE.
;  INSTRUCTION-TYPE FORCE: FORCE-DISPATCH, FORCE-JUMP, FORCE-ALU, FORCE-BYTE.
;       FORCE-DISPATCH-OR-BYTE, FORCE-ALU-OR-BYTE.
;  DEFAULT-CONDITION.  DEFAULT-BTYE. IF DISPATCH IS FORCED, RETURN NIL.
;       OTHERWISE FORCE BYTE.
;  BYTE-FIELD <BITS BITS-OVER>. DEFAULTS BYTE-INSTRUCTION.  ERROR IF OTHER THAN
;       BYTE INSTRUCTION OR DISPATCH INSTRUCTION (OR IF A ONE BIT FIELD,
;       JUMP INSTRUCTION).  ASSEMBLES THE RIGHT THING
;       TO REFERENCE BYTE, AS PER WHAT INSTRUCTION TYPE IS.
;  LISP-BYTE <%% FORM BYTE SPECIFIER>.  SIMILIAR TO BYTE-FIELD, BUT BYTE DESCRIPTION IS
;       OBTAINED BY EVAL ING ARGUMENT AND INTERPRETING IT AS A BYTE SPECIFIER.
;       I.E. PPSS WHERE PP GIVES POSITION AND SS GIVES SIZE A LA PDP-10
;       BYTE INSTRUCTION.
;  ALL-BUT-LISP-BYTE <%% FORM BYTE SPECIFIER>.  SIMILAR, BUT ADDRESSES BITS NOT IN
;       <BYTE>.  <BYTE> MUST BE EITHER LEFT OR RIGHT ADJUSTED IN 32. BITS.
;  BYTE-MASK <SYMBOLIC BYTE SPECIFIER>.  ARG CAN BE SYMBOL OR COMPOSITION OF
;       OPS AND SYMBOLS SPECIFYING A BYTE (IE CONTAINING SOMEWHERE IN THERE
;       A BYTE-FIELD OR LISP-BYTE OPERATION).  THIS IS DUG OUT BY BYTE-MASK
;       AND IS RETURNS THE VALUE OF ALL 1'S IN THE SPECIFIED BYTE.
;  BYTE-VALUE <SYMBOLIC BYTE SPECIFIER> <VALUE TO STORE IN BYTE>
;       RETURNS A VALUE OF THE SPECIFIED NUMBER IN THE SPECIFIED BYTE.
;       FOR CONVENIENCE, THE VALUE MAY BE EITHER A CONS-LAP SYMBOL OR A LISP SYMBOL.
;  FIELDS: (FIELD <FIELD NAME> <VALUE>).  NOTATION IS MADE THAT <FIELD NAME>
;       HAS BEEN SPECIFIED.  THE VALUE IS OBTAINED AS FOLLOWS:  THE PROGRAM
;       ASSOCIATED WITH <FIELD NAME> AS A SYMBOL IS RUN AND ITS VALUE MULTIPLIED
;       BY <VALUE> (THIS IS DONE RATHER THAN SHIFTING SO BIGNUMS WORK CONVIENTLY).
;       ADDITIONALLY, IF A CONS-LAP-ADDITIVE-CONSTANT
;       PROPERTY IS PRESENT ON <FIELD NAME> IT WILL BE ADDED IN AFTER MULTIPLING.
;       ANY PROPERTIES SPECIFIED IN THE RUNNING OF <FIELD NAME> STICK.
;  I-ARG.  ASSEMBLES ITS ARGUMENT INTO THE IMMEDIATE ARGUMENT FIELD OF A DISPATCH
;       INSTRUCTION.
;  ((ARG-CALL ADR) .. ) OR ((ARG-JUMP ADR) .. ).  ASSEMBLES A DISPATCH INSTRUCTION
;       WHICH DISPATCHES ON ZERO BITS TO A D-MEM ENTRY WHICH DOES A CALL (OR JUMP)
;       TO ADR.  USE IF IT IS DESIRED TO SUPPLY AN I-ARG ON AN UNCONDITIONAL
;       CALL (OR JUMP).  ((ARG-CALL-XCT-NEXT ADR) .. ) AND ((ARG-JUMP-XCT-NEXT ADR) ..)
;       ARE ALSO AVAILABLE.
;  EVAL <ARG>.  CALLS LISP EVAL ON ARG AND RETURNS (NUMERIC HOPEFULLY) VALUE.
;  LOC <ARG> SETS LOCATION COUNTER TO <ARG>.
;  MODULO <ARG> SETS LOCATION COUNTER TO BE ON A MOD <ARG> BOUNDARY.
; The following group provide communication between an assembly and microcompiled
;    code or other assemblies which may be added to it.
;  MC-LINKAGE <list of symbols>.  The values of these symbols are made available
;       to the micro-compiled-code loader and to the incremental mode of the assembler.
;       A and M memory symbols with values less than 40 are automatically
;       MC-LINKAGEifyed.
;  MC-LINKAGE sym.  Useful primarily in incrmental assemblies.  Expands to value
;       given sym in either current or previous
;      assembly.  Includes appropriate memory.
;  MC-ENTRY-ADR <microcoded-function>  allowable only in incremental assembly.
;       evaluates to I-MEM address of entry to <function> in JUMP-ADDRESS field.
;  MISC-ENTRY-ADR <misc-instruction>   allowable only in incremental assembly.
;       evaluates to I-MEM address of entry to <misc-instruction> in JUMP-ADDRESS field.
;  MC-LINKAGE-VALUE <memory> <symbol>  useful primarily in incremental assemblies.
;       <memory> must be one of NUMBER, I-MEM, D-MEM, A-MEM, M-MEM.  <symbol> must
;       have been assigned a value with the MC-LINKAGE operation (either in the
;       current assembly, or a previous one to which this assembly is being added).
;       Evaluates to the value in the appropriate memory.

;  INSTRUCTIONS FOR ASSEMBLING VALUES FOR USE WITH OA REGISTER.  (RECALL? THAT
;       THE OA "REGISTER" IS THE HACK WHEREBY THE NEXT MICRO-INSTRUCTION GETS
;       IOR-ED WITH DATA PRODUCED BY THIS ONE).
;    OA-LOW-CONTEXT OA-HIGH-CONTEXT <I-MEM STORAGE-WORD>.  ASSEMBLES <I-MEM STORAGE
;       WORD> AND RETURN EITHER HI OR LOW PART AS NUMBER FOR USE WITH DESTINATIONS
;       OA-REG-HI OR OA-REG-LOW.
; SYMBOLS MAY BE EITHER ON THE SYMTAB OR ON THE PROPERTY LIST UNDER THE INDICATOR
;  CONS-LAP-SYM.

;THE TYPE OF INSTRUCTION THAT GETS ASSEMBLED IN A GIVEN STORAGE WORD IS DETERMINED
;AS FOLLOWS:
;  FIRST THERE IS A DEFAULT, ALU-INSTRUCTION.  IT IS OVERRIDDEN BY ANY OTHER SPECIFIER.
;       THIS IS THE ONLY SPECIFIER THAT
;       CAN BE "OUT-OF-HARMONY" WITH ANY OTHER PRESENT SPECIFIER WITHOUT CAUSING AN
;       ERROR.
;  IF A DESTINATION IS PRESENT, INSTRUCTION MUST BE ALU-INSTRUCTION OR BYTE-INSTRUCTION.
;  IF AN I-MEM CONTEXT SYMBOL IS PRESENT, INSTRUCTION MUST BE JUMP-INSTRUCTION.
;  IF A D-MEM CONTEXT SYMBOL IS PRESENT, INSTRUCTION MUST BE DISPATCH-INSTRUCTION.
;  IF BOTH A M-MEM AND A A-MEM SYMBOL ARE PRESENT, INSTRUCTION MUST BE ALU-INSTRUCTION
;       OR BYTE-INSTRUCTION.
;  INSTRUCTION CAN BE FORCED BY A FORCE-INSTRUCTION PROPERTY ON ANY SYMBOL IN THE
;       WORD.
;  TWO A-MEM OR TWO M-MEM SYMBOLS IN ONE INSTRUCTION IS AN ERROR.

;ONCE INSTRUCTION TYPE IS DETERMINED, A CHECK IS MADE TO SEE THAT ALL NECESSARY
; FIELDS IN IT HAVE BEEN SPECIFIED, AND DEFAULTS SUPPLIED FOR VARIOUS OPTIONAL
; FIELDS AND MODES IF THEY WERE NOT SPECIFIED.

;RANDOM CONVENTIONS --
; LOCATION TAGS ARE DEFINED AS FIELDS. IE (FIELD JUMP-ADDRESS-MULTIPLIER NNN)
; FOR SYMBOLS IN I-MEM. (A-SOURCE-MULTIPLIER, M-SOURCE-MULTIPLIER, AND
; DISPATCH-ADDRESS-MULTIPLIER ARE THE CORRESPONDING FIELDS FOR A-MEM, M-MEM,
; AND D-MEM RESPECTIVELY).  THUS, WHEN NORMALLY EVALUATED, THEY HAVE
; THEIR VALUES IN THESE "PLACES".  THIS IS THE RIGHT THING EXCEPT FOR THESE
; CASES: 1)  DESTINATIONS.  CONVERT-VALUE-TO-DESTINATION COMPUTES AN APPROPRIATE
;               "SHIFT"
;        2)  LOCALITY D-MEM.  CONS-LAP-PASS2 DOES THE RIGHT THING.  THIS INVOLVES
;               SHIFTING THE I-MEM ADR BACK TO THE LOW PART AND MOVING THE RPN
;               BITS UP (FROM THEIR NORMAL POSITION IN A JUMP INSTRUCTION).
; OTHER FEATURES/CROCKS
;   WHEN A BYTE-FIELD OPERATION IS ENCOUNTERED BY CONS-LAP-EVAL,
;       THE INSTRUCTION CONTEXT IS FORCED TO BYTE IF IT HAS NOT ALREADY
;       BEEN COMPLETELY SPECIFIED.  THEN THE BYTE REFERENCE IS ASSEMBLED
;       IN THE MANNER APPROPRIATE TO THE INSTRUCTION CONTEXT.
;   THE SR-BIT IS STORED INVERTED (SO THAT IT WILL OFF FOR NORMAL LDB).
;       CONS-LAP-DEFAULT-AND-BUGGER REVERSES SR-BIT IF IT'S A BYTE INSTRUCTION
;   THE HARDWARE IMPLEMENTS A LEFT ROTATE FOR THE M-ROTATE FIELD.  The is the
;       "right thing" for DPB and SELECTIVE-DEPOSIT, but LDB, DISPATCH, and
;       JUMP-IF-BIT-SET need to be 32-reflected (IE ( 32. - M-ROTATE) MOD 32.)
;       This is done by CONS-LAP-DEFAULT-AND-BUGGER.
;       CODE USING THE OA-REGISTER FEATURE TO MODIFY BYTE TYPE INSTRUCTIONS
;       MUST BE AWARE OF THIS.
;  TO PUT THE ADDRESS OF A MICRO CODE LOCATION INTO A CONSTANT IN A OR M
;       MEMORY, USE THE KLUDGEY CONSTRUCTION (I-MEM-LOC <TAG>).
;  SIMILARLY, A-MEM-LOC, M-MEM-LOC, D-MEM-LOC PSEUDO-OPS EXIST.

;   OPERATION OF THE ARG-CALL, ETC, FEATURE IN DISPATCH INSTRUCTIONS.
;       SOMETIMES IT IS DESIRABLE TO USE A DISPATCH INSTRUCTION WHEN
;       REALLY ONLY AN UNCONDITIONAL TRANSFER (CALL, ETC) IS DESIRED
;       IN ORDER TO BE ABLE TO LOAD THE DISPATCH-CONSTANT REGISTER IN THE
;       SAME INSTRUCTION.  IT WOULD BE A PAIN TO HAVE TO DEFINE A ONE REGISTER
;       DISPATCH TABLE, ETC IN THIS CASE.  SO THE ASSEMBLER PROVIDES A FEATURE
;       WHEREBY ARG-CALL, ARG-JUMP, ARG-CALL-XCT-NEXT, AND ARG-JUMP-XCT-NEXT
;       ARE SPECIALLY RECOGNIZED.  USING THESE PSEUDO-OPS, THE INSTRUCTION
;       MAY BE WRITTEN AS "NORMAL" AND THE ASSEMBLER WILL TAKE CARE OF
;       ALLOCATING A D-MEM LOCATION AND MOVING THE RPN BITS AND I-MEM JUMP ADDRESS
;       BITS THERE.  THIS D-MEM LOCATION IS AUTOMATICALLY PLUGGED INTO THE
;       DISPATCH OFFSET.
;   ON A NORMAL PDP-10 STYLE LOAD BYTE, THE A-MEM ADDRESS MUST CONTAIN 0
;       FOR CORRECT OPERATION.  A-MEM
;       LOCATION 2 IS CHOSEN TO CONTAIN ZERO, AND LOCATION 3 TO CONTAIN -1,
;       MAKING A CONVENIENT PAIR FOR DOING SIGN-EXTENSION.  THE A-MEM ADDRESS
;       OF A LOAD-BYTE INSTRUCTION WILL BE DEFAULTED TO 2 IF NOT SPECIFIED.

;ENTRY POINTS INTO MICRO-CODE FROM MACRO-CODE, ETC:
;   THE MICRO-CODE-SYMBOL AREA CONTAINS ALL (INITIAL) ENTRY POINTS INTO
;  MICRO-CODE.  THE FIRST 600 Q'S OF MICRO-CODE-SYMBOL AREA GIVE THE CONTROL-MEMORY
;  TRANSFER ADDRESSES FOR MACRO-CODE MISC-INSTRUCTIONS 200-777.  FOLLOWING THAT
;  ARE OTHER ENTRY POINTS, MOSTLY FOR MICRO-COMPILED RUNTIME ROUTINES, ETC.
;  THESE LAST ARE NOT REFERENCED DYNAMICALLY, BUT JUST BY LOADERS, ETC.
;   THE MICRO-CODE-SYMBOL AREA IS COMPLETELY DETERMINED BY CONSLP UNDER CONTROL
;  OF THE (MISC-INST-ENTRY <NAME>) PSEUDO-OPERATION.
;     (MISC-INST-ENTRY <NAME>) DECLARES THAT THE CURRENT LOCATION IS THE ENTRY POINT
;       WHEN <NAME> IS EXECUTED AS A MACRO-INSTRUCTION. CONSLP LOOKS ON THE PROPERTY
;       LIST OF <NAME> TO FIND THE QLVAL PROPERTY (WHICH HAD BETTER BE THERE OR ERROR).
;       THESE QLVAL COME FROM LISPM;DEFMIC. CONSLP THEN ARRANGES FOR . TO APPEAR
;       IN THE APPROPRIATE LOCATION OF MICRO-CODE-SYMBOL AREA.
; IN ADDITION, (MICRO-CODE-ILLEGAL-ENTRY-HERE), ENCOUNTERED AT ANY TIME, FILLS
;       ALL UNUSED ENTRIES OF MICRO-CODE-SYMBOL AREA WITH THE CURRENT LOCATION.
;       (IT IS OK IF SOME OF THEM LATER GET STORED OVER WITH OTHER STUFF...)
;THE MC-LINKAGE PSEUDO-OP IS THE OTHER MECHANISM (BESIDE MISC-INST-ENTRY)
;  BY WHICH LINKAGE INFO CAN BE "COUPLED OUT" AND USED BY MICROCOMPILED ROUTINES.
;  USAGE IS (MC-LINKAGE <SYM> ..)  THE LOCATION WITHIN MEMORY OF SYM IS ADDED TO
;  MC-LINKAGE-ALIST, AND THAT IS WRITTEN AS PART OF THE ASSEMBLER STATE.  IF
;  SYM IS A LIST, CAR IS THE MICROCOMPILED NAME, CADR THE CONSLP NAME.

;THE ERROR TABLE:
; THE PSEUDO-OP (ERROR-TABLE FOO BAR BAZ...)
; WILL ADD THE LINE (LOC FOO BAR BAZ...) TO THE ERROR TABLE, WHERE LOC IS
; THE ADDRESS OF THE PRECEEDING I-MEM INSTRUCTION.  THE ERROR TABLE IS
; AN OUTPUT FILE, UCONS TABLE, WHICH CAN BE READ IN TO LISP.  IT CONTAINS
; A SETQ OF MICROCODE-ERROR-TABLE TO A LIST OF ERROR TABLE ENTRIES,
; AND A SETQ OF MICROCODE-ERROR-TABLE-VERSION TO THE SOURCE FILE VERSION
; NUMBER, WHICH CAN BE COMPARED AGAINST %MICROCODE-VERSION-NUMBER.

(DECLARE (SPECIAL DESTINATION-CONTEXT LOCALITY I-MEM-LOC D-MEM-LOC
           A-MEM-CREVICE-LIST A-CONSTANT-LOC M-CONSTANT-LOC
           CONSLP-INPUT CONSLP-OUTPUT
           VERSION-NUMBER      ;Numeric value of FN2 for this file
           BASE-VERSION-NUMBER ;NIL or, if incremental assembly, version this to augment.
           A-MEM-LOC M-MEM-LOC D-MEM-FREE-BLOCKS FIELD-INDICATORS COMBINED-VALUE
           COMBINED-INDICATORS INSTRUCTION-CONTEXT IN-DISPATCH-BLOCK
           DISPATCH-BLOCK-LIMIT DISPATCH-ARM DISPATCH-CONSTANT M-CONSTANT-LIST
           A-CONSTANT-LIST A-CONSTANT-BASE M-CONSTANT-BASE CONS-LAP-LAST-SYM
           A-MEMORY-RANGE-LIST M-MEMORY-RANGE-LIST
           I-MEMORY-RANGE-LIST D-MEMORY-RANGE-LIST
           CONS-LAP-WDS-SINCE-LAST-SYM CONS-LAP-SAVED-SYMTAB SR-BIT
           ARG-CALL-LIST CURRENT-WORD
           MC-LINKAGE-ALIST
           COLD-LOAD-AREA-SIZES PAGE-SIZE CONS-LAP-PASS2 MICRO-CODE-SYMBOL-TABLE-FILL-VALUE
           CONS-LAP-INIT-STATE   ;If this non-null, current assembly is incremental
                                 ; from this saved state.
           CURRENT-ASSEMBLY-MICRO-ENTRIES   ;List, ea element, (<type> <name> <adr>),
                                            ; in incremental assembly
           CURRENT-ASSEMBLY-TABLE           ;Error table
           CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
           CURRENT-ASSEMBLY-DEFMICS
))

(DEFVAR FILE-TRUENAMES-LISTIFIED NIL)

(DEFVAR CONS-LAP-INSIDE-COMMENT NIL
  "T in microassembly means we have seen a (BEGIN-COMMENT)
 and are ignoring thru next (END-COMMENT).")

;THE ARG CALL LIST IS AN ASSOCIATION LIST WHERE THE KEY IS THE I-MEM LOCATION
;AT WHICH AN ((ARG-CALL) ..) TYPE INSTRUCTION HAS APPEARED, AND THE VALUE
;IS THE D-MEM LOCATION THAT HAS BEEN ALLOCATED TO IT.


;ARRAYS WHICH RECEIVE THE OUTPUT OF THE ASSEMBLY
(DEFVAR I-MEM)
(DEFVAR A-MEM)
(DEFVAR D-MEM)
(DEFVAR MICRO-CODE-SYMBOL-IMAGE)

(DEFUN CONS-LAP-BARF (A B C)
  (TERPRI)
  (PRIN1 (LIST CONS-LAP-LAST-SYM CONS-LAP-WDS-SINCE-LAST-SYM))
  (PRIN1 (LIST A B C))
  (COND ((NOT (EQ C 'WARN))(BREAK "FOO"))))

(DEFUN CONS-LAP-INITIALIZE (INIT-STATE)
  (PROG (TEM)
        (CONS-LAP-INIT-LOCS-FROM-STATE INIT-STATE)
        (SETQ BASE-VERSION-NUMBER (GETF INIT-STATE 'VERSION-NUMBER))
        (SETQ A-MEM-CREVICE-LIST NIL)
        (SETQ D-MEM-FREE-BLOCKS
              (COPYTREE (GETF INIT-STATE 'D-MEM-FREE-BLOCKS
                              '(NIL (4000 . 0)))))      ;A BLOCK OF 4000 STARTING AT 0
        (ALLREMPROP 'CONS-LAP-USER-SYMBOL)
        (SETQ M-CONSTANT-LIST                   ;DUMMY UP SLOTS FOR USAGE COUNT AND LAST
              (COND ((SETQ TEM (GETF INIT-STATE 'M-CONSTANT-LIST))  ;USE
                     (MAPCAR (FUNCTION (LAMBDA (X)
                                         (APPEND X '(100000 NIL) NIL)))
                             TEM))
                    (T NIL)))
        (SETQ A-CONSTANT-LIST
              (COND ((SETQ TEM (GETF INIT-STATE 'A-CONSTANT-LIST))
                     (MAPCAR (FUNCTION (LAMBDA (X)
                                         (APPEND X '(100000 NIL) NIL)))
                             TEM))
                    (T NIL)))
        (SETQ A-CONSTANT-BASE NIL)              ;SEE CONS-LAP-LOC-MODULO
        (SETQ M-CONSTANT-BASE NIL)
        (SETQ A-MEMORY-RANGE-LIST NIL)
        (SETQ M-MEMORY-RANGE-LIST NIL)
        (SETQ I-MEMORY-RANGE-LIST NIL)
        (SETQ D-MEMORY-RANGE-LIST NIL)
        (SETQ CURRENT-ASSEMBLY-MICRO-ENTRIES NIL)
        (SETQ CURRENT-ASSEMBLY-TABLE NIL)
  ;do not initialize current-assembly-defmics here computed during readin phase
        (SETQ CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
              (GETF INIT-STATE 'HIGHEST-MISC-ENTRY 0))
        (SETQ MC-LINKAGE-ALIST (GETF INIT-STATE 'MC-LINKAGE-ALIST))
        (DOLIST (E MC-LINKAGE-ALIST)
          (COND ((AND (MEMQ (CADR E) '(A M))
                      (< (CADDR E) 40))
                 (CONS-LAP-DEFINE-LINKAGE-SYMBOL (CAR E)))))
        (CONS-LAP-ALLOCATE-ARRAYS)
        (ALLREMPROP 'CONS-LAP-B-PTR)
))

(DEFUN ALLREMPROP (**INDICATOR**)
  (DECLARE (SPECIAL **INDICATOR**))
  (MAPATOMS (FUNCTION (LAMBDA (X) (REMPROP X **INDICATOR**)))))

(DEFUN MAKE-ASSEMBLER-STATE-LIST NIL
  (LIST 'I-MEM-LOC I-MEM-LOC 'D-MEM-LOC D-MEM-LOC 'A-MEM-LOC A-MEM-LOC
        'M-MEM-LOC M-MEM-LOC
        'A-CONSTANT-LOC A-CONSTANT-LOC 'A-CONSTANT-BASE A-CONSTANT-BASE
        'M-CONSTANT-LOC M-CONSTANT-LOC 'M-CONSTANT-BASE M-CONSTANT-BASE
        'D-MEM-FREE-BLOCKS D-MEM-FREE-BLOCKS
        'M-CONSTANT-LIST (MAKE-CONSTANT-LIST M-CONSTANT-LIST)
        'A-CONSTANT-LIST (MAKE-CONSTANT-LIST A-CONSTANT-LIST)
        'MICRO-CODE-SYMBOL-TABLE-FILL-VALUE
        (COND ((BOUNDP 'MICRO-CODE-SYMBOL-TABLE-FILL-VALUE)
               MICRO-CODE-SYMBOL-TABLE-FILL-VALUE)
              (T NIL))
        'A-MEMORY-RANGE-LIST A-MEMORY-RANGE-LIST
        'M-MEMORY-RANGE-LIST M-MEMORY-RANGE-LIST
        'I-MEMORY-RANGE-LIST I-MEMORY-RANGE-LIST
        'D-MEMORY-RANGE-LIST D-MEMORY-RANGE-LIST
        'MC-LINKAGE-ALIST MC-LINKAGE-ALIST
        'MICRO-ENTRIES CURRENT-ASSEMBLY-MICRO-ENTRIES
        'HIGHEST-MISC-ENTRY CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
        'VERSION-NUMBER VERSION-NUMBER
        'BASE-VERSION-NUMBER BASE-VERSION-NUMBER        ;nil or version number this
                                                        ; loads into.
        'FILE-TRUENAMES-LISTIFIED FILE-TRUENAMES-LISTIFIED
        ))

(DEFUN CONS-LAP-ALLOCATE-ARRAYS NIL
  (SETQ I-MEM (MAKE-ARRAY SI:SIZE-OF-HARDWARE-CONTROL-MEMORY)
        A-MEM (MAKE-ARRAY 2000)
        D-MEM (MAKE-ARRAY 4000))
  (SETQ MICRO-CODE-SYMBOL-IMAGE (MAKE-ARRAY MICRO-CODE-SYMBOL-AREA-SIZE)))

(DEFUN CONS-LAP-INIT-LOCS-FROM-STATE (INIT-STATE)
  (PROG (TEM)
        (SETQ I-MEM-LOC (GETF INIT-STATE 'I-MEM-LOC 0))
        (SETQ D-MEM-LOC (GETF INIT-STATE 'D-MEM-LOC 0))
        (SETQ A-MEM-LOC (COND ((SETQ TEM (GETF INIT-STATE 'A-MEM-LOC))
                               (MAX TEM (GETF INIT-STATE 'A-CONSTANT-LOC 0)))
                              (T 0)))
        (SETQ M-MEM-LOC (COND ((SETQ TEM (GETF INIT-STATE 'M-MEM-LOC))
                               (MAX TEM (GETF INIT-STATE 'M-CONSTANT-LOC 0)))
                              (T 0)))
))

(DEFVAR PATHNAME-DEFAULTS)

;IF INIT-STATE NON-NIL, ITS REPRESENTS A PREVIOUS ASSEMBLY
; IS TO BE AUGMENTED BY THE CURRENT ASSEMBLY.
;--- see ASSEMBLE-SYSTEM below which is the new interface to this stuff..
(DEFUN ASSEMBLE (&OPTIONAL FN INIT-STATE DONT-RE-READ &AUX INPUT-FILE INPUT-TRUENAME)
  (PKG-BIND "UA"                        ;Put user typein into our package during assembly
    (COND ((NOT (BOUNDP 'PATHNAME-DEFAULTS))
           (SETQ PATHNAME-DEFAULTS (FS:MAKE-PATHNAME-DEFAULTS))
           (FS:SET-DEFAULT-PATHNAME "SYS: UCADR; UCADR LISP >" PATHNAME-DEFAULTS)))
    (COND ((NULL FN)
           (FORMAT T "~&Enter input file name (default ~A): "
                   (FS:DEFAULT-PATHNAME PATHNAME-DEFAULTS))
           (SETQ FN (READLINE))))
    (SETQ INPUT-FILE (FS:MERGE-AND-SET-PATHNAME-DEFAULTS FN PATHNAME-DEFAULTS))
    (SETQ CONSLP-INPUT
          (SETQ CONSLP-OUTPUT (INTERN (STRING-UPCASE (FUNCALL INPUT-FILE ':NAME)))))
    (SETQ INPUT-TRUENAME (FUNCALL INPUT-FILE ':TRUENAME)
          VERSION-NUMBER (FUNCALL INPUT-TRUENAME ':VERSION))
    (LET ((TIME (TIME))
          (DR (READ-METER 'SI:%COUNT-DISK-PAGE-READS))
          (DW (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES)))
      (COND ((AND DONT-RE-READ (BOUNDP CONSLP-INPUT))
             (FORMAT T "~&Ucode already read in.~%"))
            ((OR INIT-STATE             ;Use regular reader for incremental assembly
                 (NOT (FBOUNDP 'READ-UCODE)))
             (FORMAT T "Reading ~A~%" INPUT-TRUENAME)
             (SETQ CURRENT-ASSEMBLY-DEFMICS NIL)
             (READFILE INPUT-FILE "UA"))
            (T
             (FORMAT T "Reading ~A with fast reader~%" INPUT-TRUENAME)
             (SETQ CURRENT-ASSEMBLY-DEFMICS NIL)
             (READ-UCODE INPUT-FILE)))
      (SETQ TIME (TIME-DIFFERENCE (TIME) TIME))
      (FORMAT T "~&Read-in time ~D:~D, ~D disk reads, ~D disk writes~%"
              (TRUNCATE TIME 3600.) (\ (TRUNCATE TIME 60.) 60.)
              (- (READ-METER 'SI:%COUNT-DISK-PAGE-READS) DR)
              (- (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES) DW)))
    (DOLIST (X CURRENT-ASSEMBLY-DEFMICS)        ;process UA-DEFMICs read
      (APPLY (FUNCTION UA-DO-DEFMIC) X))
    (LET ((TIME (TIME))
          (DR (READ-METER 'SI:%COUNT-DISK-PAGE-READS))
          (DW (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES)))
      (FORMAT T "~&Begin Assembly~%")
      (CONS-LAP (SYMEVAL CONSLP-INPUT) INIT-STATE)
      (SETQ TIME (TIME-DIFFERENCE (TIME) TIME))
      (COND ((NULL INIT-STATE)          ;dont write on incremental assembly
             (WRITE-VARIOUS-OUTPUTS INPUT-FILE)))
      (FORMAT T "~&Assembly time ~D:~D, ~D disk reads, ~D disk writes~%"
              (TRUNCATE TIME 3600.) (\ (TRUNCATE TIME 60.) 60.)
              (- (READ-METER 'SI:%COUNT-DISK-PAGE-READS) DR)
              (- (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES) DW)))))


(DEFUN WRITE-VARIOUS-OUTPUTS-SYSTEM (OUTPUT-GENERIC-PATHNAME)
  (COND ((Y-OR-N-P "WRITE-MCR? ")
         (WRITE-MCR-FILE (FUNCALL OUTPUT-GENERIC-PATHNAME
                                  ':NEW-TYPE
                                  "MCR")
                         BASE-VERSION-NUMBER)
         (WRITE-TBL-FILE (FUNCALL OUTPUT-GENERIC-PATHNAME
                                  ':NEW-TYPE
                                  "LOCS"))
         (WRITE-ERROR-TABLE (FUNCALL OUTPUT-GENERIC-PATHNAME
                                     ':NEW-TYPE
                                     "TBL")))))

;obsolete now.  see write-various-outputs-system
(DEFUN WRITE-VARIOUS-OUTPUTS (INPUT-FILE)
  ;; Binary for the main microcode lives on another directory.
  ;; Allow the user to type the name of the translated file explicitly.
  (LET ((INPUT-FILE-1 INPUT-FILE))
    (OR (EQUAL (FUNCALL INPUT-FILE-1 ':HOST) "SYS")
        (SETQ INPUT-FILE-1 (FUNCALL (FS:DEFAULT-PATHNAME PATHNAME-DEFAULTS "SYS")
                                    ':BACK-TRANSLATED-PATHNAME INPUT-FILE-1)))
    (AND (EQUAL (FUNCALL INPUT-FILE-1 ':DIRECTORY) "UCADR")
         (SETQ INPUT-FILE (FUNCALL INPUT-FILE-1 ':NEW-DIRECTORY "UBIN"))))
  (SETQ CONSLP-OUTPUT-PATHNAME (FUNCALL INPUT-FILE ':NEW-PATHNAME
                                        ':NAME (STRING CONSLP-OUTPUT)
                                        ':TYPE ':UNSPECIFIC ':VERSION ':UNSPECIFIC))
  (COND ((Y-OR-N-P "WRITE-MCR? ")
         (WRITE-MCR BASE-VERSION-NUMBER)
         (WRITE-TBL-FILE (FUNCALL CONSLP-OUTPUT-PATHNAME
                                  ':NEW-PATHNAME ':TYPE "LOCS"
                                  ':VERSION VERSION-NUMBER))
         (WRITE-ERROR-TABLE (FUNCALL CONSLP-OUTPUT-PATHNAME
                                     ':NEW-TYPE-AND-VERSION
                                     "TBL" VERSION-NUMBER)))))

;somewhat fake interface to make-system.  Main advantage is it allows UCADR file to be split.
;sample DEFSYSTEM looks like:
(COMMENT
  (SI:DEFINE-SIMPLE-TRANSFORMATION :MICRO-ASSEMBLE UA:MICRO-ASSEMBLE-SYSTEM-TOP-LEVEL
     UA:FILE-TEST-ALWAYS ("LISP") ("MCR")
     NIL NIL T) ;LOAD like

  (SI:DEFINE-MAKE-SYSTEM-SPECIAL-VARIABLE *FILES-TO-MICRO-ASSEMBLE* NIL)

  (DEFSYSTEM UCODE
    (:NAME "Ucode")
    (:PACKAGE "UA")
    (:MICRO-ASSEMBLE ("sys:ucadr;test1" "sys:ucadr;test2")))
  )  ;end comment
 ;note the transformation definition must be in effect when the DEFSYSTEM is evaluated.

(DEFMACRO (:USE-FAST-READER SI:DEFSYSTEM-MACRO) (T-OR-NIL)
  (PUTPROP (LOCF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-DEFINED*)) T-OR-NIL 'FAST-READ-SWITCH)
  NIL)

(DEFMACRO (:OUTPUT-PATHNAME SI:DEFSYSTEM-MACRO) (PATHNAME)
  (PUTPROP (LOCF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-DEFINED*)) PATHNAME 'OUTPUT-PATHSTRING)
  NIL)

(DECLARE (SPECIAL SI:*FILES-TO-MICRO-ASSEMBLE*))

(DEFUN MICRO-ASSEMBLE-SYSTEM-TOP-LEVEL (INFILE OUTFILE)
 ;  (FORMAT T "~% infile : ~s outfile: ~s" INFILE OUTFILE)
  OUTFILE  ;We don't have an output file for each input file anyway.
  (COND ((NULL SI:*FILES-TO-MICRO-ASSEMBLE*)
         (PUSH `(MICRO-ASSEMBLE-SYSTEM-DO-IT)
               SI:*MAKE-SYSTEM-FORMS-TO-BE-EVALED-AFTER*)))
  (SETQ SI:*FILES-TO-MICRO-ASSEMBLE*
        (NCONC SI:*FILES-TO-MICRO-ASSEMBLE* (LIST INFILE))))

(DEFUN MICRO-ASSEMBLE-SYSTEM-DO-IT ()
  ;(FORMAT T "~%micro-assemble-do-it ~s" SI:*FILES-TO-MICRO-ASSEMBLE*)
  (LET* ((FILE-TRUENAMES (MAPCAR #'(LAMBDA (X) (FUNCALL X ':TRUENAME))
                                 SI:*FILES-TO-MICRO-ASSEMBLE*))
         (FILE-TRUENAMES-LISTIFIED (MAPCAR #'(LAMBDA (X) (LISTIFY-PATHNAME X))
                                           FILE-TRUENAMES))
         (OUTPUT-PATHSTRING (GET (LOCF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-MADE*))
                                 'OUTPUT-PATHSTRING))
         (OUTPUT-GENERIC-PATHNAME (FS:PARSE-PATHNAME OUTPUT-PATHSTRING))
         (OUTPUT-MCR-PATHNAME (FUNCALL OUTPUT-GENERIC-PATHNAME ':NEW-TYPE "MCR"))
         (PROBE (PROBEF OUTPUT-MCR-PATHNAME))
         (OUTPUT-OLD-TRUENAME (FUNCALL PROBE ':TRUENAME))
         (OLD-VERSION-NUMBER (FUNCALL OUTPUT-OLD-TRUENAME ':VERSION)))
    (SETQ VERSION-NUMBER (1+ OLD-VERSION-NUMBER))
    (SETQ OUTPUT-GENERIC-PATHNAME (FUNCALL OUTPUT-GENERIC-PATHNAME
                                           ':NEW-VERSION VERSION-NUMBER))
    (FORMAT T "~%Output will be version ~D" VERSION-NUMBER)
    (ASSEMBLE-SYSTEM OUTPUT-GENERIC-PATHNAME
                     FILE-TRUENAMES NIL NIL
                     (GET (LOCF (SI:SYSTEM-PLIST SI:*SYSTEM-BEING-MADE*))
                          'FAST-READ-SWITCH))))

(DEFUN LISTIFY-PATHNAME (PATHNAME)
  (LIST (FUNCALL (FUNCALL PATHNAME ':HOST) ':NAME)
        (FUNCALL PATHNAME ':DEVICE)
        (FUNCALL PATHNAME ':NAME)
        (FUNCALL PATHNAME ':TYPE)
        (FUNCALL PATHNAME ':VERSION)))

;IF INIT-STATE NON-NIL, ITS REPRESENTS A PREVIOUS ASSEMBLY
; IS TO BE AUGMENTED BY THE CURRENT ASSEMBLY.
(DEFUN ASSEMBLE-SYSTEM (OUTPUT-GENERIC-PATHNAME
                        FILE-TRUENAMES INIT-STATE RE-READ USE-FAST-READER)
  (PKG-BIND "UA"                        ;Put user typein into our package during assembly
    (LET ((TIME (TIME))
          (DR (READ-METER 'SI:%COUNT-DISK-PAGE-READS))
          (DW (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES)))
      (DOLIST (FILE-TRUENAME FILE-TRUENAMES)
           ;read in S-exp if necessary.  Also save DEFMICSs on property list of TRUENAME.
        (ASSEMBLE-READ-FILE FILE-TRUENAME USE-FAST-READER RE-READ))
      (SETQ TIME (TIME-DIFFERENCE (TIME) TIME))
      (FORMAT T "~&Read-in time ~D:~D, ~D disk reads, ~D disk writes~%"
              (TRUNCATE TIME 3600.) (\ (TRUNCATE TIME 60.) 60.)
              (- (READ-METER 'SI:%COUNT-DISK-PAGE-READS) DR)
              (- (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES) DW)))
    (DOLIST (FILE-TRUENAME FILE-TRUENAMES)
      (DOLIST (X (FUNCALL FILE-TRUENAME ':GET 'DEFMICS))        ;process UA-DEFMICs
        (APPLY (FUNCTION UA-DO-DEFMIC) X)))
    (LET ((TIME (TIME))
          (DR (READ-METER 'SI:%COUNT-DISK-PAGE-READS))
          (DW (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES)))
      (FORMAT T "~&Begin Assembly~%")
      (CONS-LAP-INITIALIZE INIT-STATE)
      (CONS-LAP-SYSTEM FILE-TRUENAMES INIT-STATE)
      (SETQ TIME (TIME-DIFFERENCE (TIME) TIME))
      (COND ((NULL INIT-STATE)          ;dont write on incremental assembly
             (WRITE-VARIOUS-OUTPUTS-SYSTEM OUTPUT-GENERIC-PATHNAME)))
      (FORMAT T "~&Assembly time ~D:~D, ~D disk reads, ~D disk writes~%"
              (TRUNCATE TIME 3600.) (\ (TRUNCATE TIME 60.) 60.)
              (- (READ-METER 'SI:%COUNT-DISK-PAGE-READS) DR)
              (- (READ-METER 'SI:%COUNT-DISK-PAGE-WRITES) DW)))))

(DEFUN ASSEMBLE-READ-FILE (FILE-TRUENAME USE-FAST-READER RE-READ)
  (COND ((OR RE-READ
             (NULL (FUNCALL FILE-TRUENAME ':GET 'UA-SEXP)))
         (LET ((CURRENT-ASSEMBLY-DEFMICS NIL)
               (NAME (INTERN (STRING-UPCASE (FUNCALL FILE-TRUENAME ':NAME)))))
           (MAKUNBOUND NAME)
           (COND (USE-FAST-READER
                  (FORMAT T "~%Reading ~A with fast reader" FILE-TRUENAME)
                  (READ-UCODE FILE-TRUENAME))
                 (T
                  (FORMAT T "~%Reading ~A" FILE-TRUENAME)
                  (READFILE FILE-TRUENAME "UA")))
           (IF (NOT (BOUNDP NAME))
               (FERROR NIL "~%Reading ~s failed to set the symbol ~s" FILE-TRUENAME NAME))
           (FUNCALL FILE-TRUENAME ':PUTPROP (SYMEVAL NAME) 'UA-SEXP)
           (FUNCALL FILE-TRUENAME ':PUTPROP CURRENT-ASSEMBLY-DEFMICS 'DEFMICS)))
        (T (FORMAT T "~%Already read ~S" FILE-TRUENAME))))

(DEFUN CONS-LAP-SYSTEM (FILE-TRUENAMES CONS-LAP-INIT-STATE)
  (PROG (;I-MEM-LOC D-MEM-LOC A-MEM-LOC M-MEM-LOC M-CONSTANT-LOC A-CONSTANT-LOC ;USE TOP LEVEL
         ;M-CONSTANT-LIST A-CONSTANT-LIST M-CONSTANT-BASE A-CONSTANT-BASE  ;BINDINGS FOR THESE
         ;D-MEM-FREE-BLOCKS MICRO-CODE-SYMBOL-TABLE-FILL-VALUE
         ;A-MEMORY-RANGE-LIST M-MEMORY-RANGE-LIST I-MEMORY-RANGE-LIST D-MEMORY-RANGE-LIST
         ;CURRENT-ASSEMBLY-MICRO-ENTRIES CURRENT-ASSEMBLY-TABLE CURRENT-ASSEMBLY-DEFMICS
         ;CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
         ;MC-LINKAGE-ALIST
         INITIAL-A-MEM-LOC INITIAL-M-MEM-LOC INITIAL-I-MEM-LOC INITIAL-D-MEM-FREE-BLOCKS
         LOCALITY
         IN-DISPATCH-BLOCK CONS-LAP-LAST-SYM CONS-LAP-WDS-SINCE-LAST-SYM
         DISPATCH-BLOCK-LIMIT DISPATCH-ARM CONS-LAP-PASS2
         DISPATCH-CONSTANT ARG-CALL-LIST CONS-LAP-INSIDE-COMMENT)
        (SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
        (SETQ INITIAL-A-MEM-LOC A-MEM-LOC INITIAL-M-MEM-LOC M-MEM-LOC
              INITIAL-I-MEM-LOC I-MEM-LOC)
        (SETQ INITIAL-D-MEM-FREE-BLOCKS (COPYTREE D-MEM-FREE-BLOCKS))
        (DOLIST (*UA-TRUENAME* FILE-TRUENAMES)
          (LET ((BEG-I-MEM-LOC I-MEM-LOC))
            (DOLIST (S (FUNCALL *UA-TRUENAME* ':GET 'UA-SEXP))
              (CONS-LAP-PASS1 S))
            (WHEN CONS-LAP-INSIDE-COMMENT
              (CONS-LAP-BARF *UA-TRUENAME* "Ends inside a (BEGIN-COMMENT)" 'BARF))
            (FORMAT T "~%file ~A assembled into ~D. I-MEM locs"
                    *UA-TRUENAME* (- I-MEM-LOC BEG-I-MEM-LOC))))
        (SETQ M-CONSTANT-LOC (SETQ M-CONSTANT-BASE M-MEM-LOC))
        (SETQ A-CONSTANT-LOC (SETQ A-CONSTANT-BASE A-MEM-LOC))
        (SETQ CONS-LAP-LAST-SYM NIL)
        (SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
        (SETQ CONS-LAP-PASS2 T)
        (CONS-LAP-INIT-LOCS-FROM-STATE CONS-LAP-INIT-STATE)
        (DOLIST (*UA-TRUENAME* FILE-TRUENAMES)
          (DOLIST (S (FUNCALL *UA-TRUENAME* ':GET 'UA-SEXP))
            (CONS-LAP-PASS2 S))
          (WHEN CONS-LAP-INSIDE-COMMENT
            (CONS-LAP-BARF *UA-TRUENAME* "Ends inside a (BEGIN-COMMENT)" 'BARF)))
        (COND ((NOT (= M-MEM-LOC M-CONSTANT-BASE))
               (CONS-LAP-BARF (LIST M-MEM-LOC M-CONSTANT-BASE) 'CLD-M-MEM 'BARF)))
        (COND ((NOT (= A-MEM-LOC A-CONSTANT-BASE))
               (CONS-LAP-BARF (LIST A-MEM-LOC A-CONSTANT-BASE) 'CLD-A-MEM 'BARF)))
        (SETQ LOCALITY 'M-MEM)
        (CONS-LAP-STORE-CONSTANT-LIST A-MEM
                                      M-CONSTANT-LIST)  ;THIS STORES
                        ;THE COMPLETE LIST (INCLUDING THOSE FROM PREVIOUS ASSEMBLY)
                        ;BUT I GUESS THATS OK.
        (SETQ LOCALITY 'A-MEM)
        (CONS-LAP-STORE-CONSTANT-LIST A-MEM
                                      A-CONSTANT-LIST)
        (SETQ A-MEMORY-RANGE-LIST (CONS (LIST INITIAL-A-MEM-LOC
                                              (- (MAX A-MEM-LOC A-CONSTANT-LOC)
                                                 INITIAL-A-MEM-LOC))
                                        A-MEMORY-RANGE-LIST))
        (SETQ M-MEMORY-RANGE-LIST (CONS (LIST INITIAL-M-MEM-LOC
                                              (- (MAX M-MEM-LOC M-CONSTANT-LOC)
                                                 INITIAL-M-MEM-LOC))
                                        M-MEMORY-RANGE-LIST))
        (SETQ I-MEMORY-RANGE-LIST (CONS (LIST INITIAL-I-MEM-LOC
                                              (- I-MEM-LOC INITIAL-I-MEM-LOC))
                                        I-MEMORY-RANGE-LIST))
        (LET ((TEM (FIND-D-MEM-RANGES-USED
                      (CDR INITIAL-D-MEM-FREE-BLOCKS)
                      (CDR D-MEM-FREE-BLOCKS))))
          (COND (TEM (SETQ D-MEMORY-RANGE-LIST (APPEND TEM D-MEMORY-RANGE-LIST)))))
        (RETURN "Now do (WRITE-VARIOUS-OUTPUTS) and//or (CONS-DUMP-MEMORIES)")))

(DEFUN FILE-TEST-ALWAYS (F1 F2) F1 F2 T)

;This is used in reading in the DEFMIC file.
;Only sets up the QLVAL property, not the QINTCMP property and not the function lists.
(defun defmic (&quote name opcode arglist lisp-function-p &optional no-qintcmp
               &aux function-name instruction-name)
  (if (atom name)
      (setq function-name name instruction-name name)
    (setq function-name (car name) instruction-name (cdr name)))
  (putprop instruction-name opcode 'qlval))

;This one obsolete, see CONS-LAP-SYSTEM.
(DEFUN CONS-LAP (U-PROG &OPTIONAL CONS-LAP-INIT-STATE)
  (PROG (;I-MEM-LOC D-MEM-LOC A-MEM-LOC M-MEM-LOC M-CONSTANT-LOC A-CONSTANT-LOC ;USE TOP LEVEL
         ;M-CONSTANT-LIST A-CONSTANT-LIST M-CONSTANT-BASE A-CONSTANT-BASE  ;BINDINGS FOR THESE
         ;D-MEM-FREE-BLOCKS MICRO-CODE-SYMBOL-TABLE-FILL-VALUE
         ;A-MEMORY-RANGE-LIST M-MEMORY-RANGE-LIST I-MEMORY-RANGE-LIST D-MEMORY-RANGE-LIST
         ;CURRENT-ASSEMBLY-MICRO-ENTRIES CURRENT-ASSEMBLY-TABLE CURRENT-ASSEMBLY-DEFMICS
         ;CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
         ;MC-LINKAGE-ALIST
         INITIAL-A-MEM-LOC INITIAL-M-MEM-LOC INITIAL-I-MEM-LOC INITIAL-D-MEM-FREE-BLOCKS
         LOCALITY
         IN-DISPATCH-BLOCK CONS-LAP-LAST-SYM CONS-LAP-WDS-SINCE-LAST-SYM
         DISPATCH-BLOCK-LIMIT T1 DISPATCH-ARM CONS-LAP-PASS2
         DISPATCH-CONSTANT ARG-CALL-LIST)
        (SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
        (CONS-LAP-INITIALIZE CONS-LAP-INIT-STATE)
        (SETQ INITIAL-A-MEM-LOC A-MEM-LOC INITIAL-M-MEM-LOC M-MEM-LOC
              INITIAL-I-MEM-LOC I-MEM-LOC)
        (SETQ INITIAL-D-MEM-FREE-BLOCKS (COPYTREE D-MEM-FREE-BLOCKS))
        (SETQ T1 U-PROG)
L1      (COND ((NULL T1) (GO L2)))
        (CONS-LAP-PASS1 (CAR T1))
        (SETQ T1 (CDR T1))
        (GO L1)
L2      (SETQ M-CONSTANT-LOC (SETQ M-CONSTANT-BASE M-MEM-LOC))
        (SETQ A-CONSTANT-LOC (SETQ A-CONSTANT-BASE A-MEM-LOC))
        (SETQ CONS-LAP-LAST-SYM NIL)
        (SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
        (SETQ CONS-LAP-PASS2 T)
        (CONS-LAP-INIT-LOCS-FROM-STATE CONS-LAP-INIT-STATE)
        (SETQ T1 U-PROG)
L3      (COND ((NULL T1) (GO L4)))
        (CONS-LAP-PASS2 (CAR T1))
        (SETQ T1 (CDR T1))
        (GO L3)
L4      (COND ((NOT (= M-MEM-LOC M-CONSTANT-BASE))
               (CONS-LAP-BARF (LIST M-MEM-LOC M-CONSTANT-BASE) 'CLD-M-MEM 'BARF)))
        (COND ((NOT (= A-MEM-LOC A-CONSTANT-BASE))
               (CONS-LAP-BARF (LIST A-MEM-LOC A-CONSTANT-BASE) 'CLD-A-MEM 'BARF)))
        (SETQ LOCALITY 'M-MEM)
        (CONS-LAP-STORE-CONSTANT-LIST A-MEM
                                      M-CONSTANT-LIST)  ;THIS STORES
                        ;THE COMPLETE LIST (INCLUDING THOSE FROM PREVIOUS ASSEMBLY)
                        ;BUT I GUESS THATS OK.
        (SETQ LOCALITY 'A-MEM)
        (CONS-LAP-STORE-CONSTANT-LIST A-MEM
                                      A-CONSTANT-LIST)
        (SETQ A-MEMORY-RANGE-LIST (CONS (LIST INITIAL-A-MEM-LOC
                                              (- (MAX A-MEM-LOC A-CONSTANT-LOC)
                                                 INITIAL-A-MEM-LOC))
                                        A-MEMORY-RANGE-LIST))
        (SETQ M-MEMORY-RANGE-LIST (CONS (LIST INITIAL-M-MEM-LOC
                                              (- (MAX M-MEM-LOC M-CONSTANT-LOC)
                                                 INITIAL-M-MEM-LOC))
                                        M-MEMORY-RANGE-LIST))
        (SETQ I-MEMORY-RANGE-LIST (CONS (LIST INITIAL-I-MEM-LOC
                                              (- I-MEM-LOC INITIAL-I-MEM-LOC))
                                        I-MEMORY-RANGE-LIST))
        (LET ((TEM (FIND-D-MEM-RANGES-USED
                      (CDR INITIAL-D-MEM-FREE-BLOCKS)
                      (CDR D-MEM-FREE-BLOCKS))))
          (COND (TEM (SETQ D-MEMORY-RANGE-LIST (APPEND TEM D-MEMORY-RANGE-LIST)))))
        (RETURN "Now do (WRITE-VARIOUS-OUTPUTS) and//or (CONS-DUMP-MEMORIES)")))

(DEFUN WRITE-ERROR-TABLE (FN)
  (WITH-OPEN-FILE (OUTPUT-FILE FN '(:OUT :BLOCK))
    (PRINT `(SETQ MICROCODE-ERROR-TABLE-VERSION-NUMBER
                  ,VERSION-NUMBER)
           OUTPUT-FILE)
    (TERPRI OUTPUT-FILE)
    (PRINC "(SETQ MICROCODE-ERROR-TABLE '(" OUTPUT-FILE)
    (DOLIST (I CURRENT-ASSEMBLY-TABLE)
      (PRINT I OUTPUT-FILE))
    (PRINC "))" OUTPUT-FILE)
    (TERPRI OUTPUT-FILE)))

(DEFUN WRITE-TBL-FILE (FN)
  (WITH-OPEN-FILE (OUTPUT-FILE FN '(:OUT))
    (PRINT 'LOCATIONS-USED OUTPUT-FILE)
    (PRINT (LIST 'A-MEM (MAX A-MEM-LOC A-CONSTANT-LOC)) OUTPUT-FILE)
    (PRINT (LIST 'M-MEM (MAX M-MEM-LOC M-CONSTANT-LOC)) OUTPUT-FILE)
    (PRINT (LIST 'I-MEM I-MEM-LOC) OUTPUT-FILE)
    (PRINT (LIST 'D-MEM (- 4000 (GET-D-MEM-FREE-LOCS (CDR D-MEM-FREE-BLOCKS))))
           OUTPUT-FILE)
    (TERPRI OUTPUT-FILE))
  FN)

;For each old free block, determine what part of it has been used and
; make a list of those ranges.
(DEFUN FIND-D-MEM-RANGES-USED (OLD-FREE-BLOCKS NEW-FREE-BLOCKS)
  (PROG (ANS SA LEN NEW-SA NEW-LEN)
     L  (COND ((NULL OLD-FREE-BLOCKS) (RETURN ANS)))
        (SETQ SA (CDAR OLD-FREE-BLOCKS) LEN (CAAR OLD-FREE-BLOCKS))
     L1 (MULTIPLE-VALUE (NEW-SA NEW-LEN)
          (FIND-NEXT-FREE-BLOCK-HIGHER-OR-EQUAL SA NEW-FREE-BLOCKS))
        (COND ((NULL NEW-SA)
               (SETQ ANS (CONS (LIST SA LEN) ANS))    ;EVIDENTLY, BLOCK MUST BE USED NOW
               (GO X1))
              ((NOT (= SA NEW-SA))
               (SETQ ANS (CONS (LIST SA (MIN LEN (- NEW-SA SA)))  ;PART (OR ALL) BLOCK USED
                               ANS))))
        (SETQ LEN (- LEN (- (+ NEW-SA NEW-LEN) SA)))    ;ADVANCE TO ABOVE THAT ONE
        (COND ((<= LEN 0) (GO X1))
              (T (SETQ SA (+ NEW-SA NEW-LEN))
                 (GO L1)))
     X1 (SETQ OLD-FREE-BLOCKS (CDR OLD-FREE-BLOCKS))
        (GO L)))

(DEFUN FIND-NEXT-FREE-BLOCK-HIGHER-OR-EQUAL (SA FREE-BLOCKS)
  (PROG (ANS)
     L  (COND ((NULL FREE-BLOCKS)
               (COND ((NULL ANS) (RETURN NIL))
                     (T (RETURN (CDR ANS) (CAR ANS)))))
              ((AND (>= (CDAR FREE-BLOCKS) SA)
                    (OR (NULL ANS)
                        (< (CDAR FREE-BLOCKS) (CDR ANS))))
               (SETQ ANS (CAR FREE-BLOCKS))))
        (SETQ FREE-BLOCKS (CDR FREE-BLOCKS))
        (GO L)))

(DEFUN GET-D-MEM-FREE-LOCS (X)
  (COND ((NULL X) 0)
        (T (+ (CAAR X) (GET-D-MEM-FREE-LOCS (CDR X))))))

(DEFUN CONS-LAP-STORE-CONSTANT-LIST (MEM L)
  (PROG NIL
 L      (COND ((NULL L) (RETURN NIL)))
        (STORE (ARRAYCALL NIL MEM (CADAR L)) (CAAR L))
        (SETQ L (CDR L))
        (GO L)))

;CONSTANT LISTS.
;A LIST OF LISTS.  CAR IS VALUE OF CONSTANT, CADR IS ADDRESS, CADDR IS #USERS, CADDDR IS
;       LAST PC TO USE IT.

; ARG IS A-CONSTANT-LIST OR M-CONSTANT-LIST
(DEFUN CONS-LAP-REPORT-CONSTANTS-USAGE (L)
  (SETQ L (SORT (COPYLIST L) (FUNCTION (LAMBDA (X Y) (< (CADDR X) (CADDR Y))))))
  (TERPRI)
  (PRINC "#USES VALUE   USEPC")
  (DO L L (CDR L) (NULL L)
    (PRINT (CADDR (CAR L)))
    (TYO 11)
    (PRIN1 (CAAR L))
    (TYO 11)
    (PRIN1 (CADDDR (CAR L))))
  (TERPRI))

(DEFUN CONS-LAP-PASS1 (WD)
  (PROG (CURRENT-WORD)
        (SETQ CURRENT-WORD WD)                  ;FOR DEBUGGING
        (COND (CONS-LAP-INSIDE-COMMENT
               (WHEN (EQUAL WD '(END-COMMENT))
                 (SETQ CONS-LAP-INSIDE-COMMENT NIL))
               (RETURN NIL))
              ((ATOM WD)
               (SETQ CONS-LAP-LAST-SYM WD)
               (SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
               (CONS-LAP-DEFSYM
                 WD
                 (LIST LOCALITY
                       (CONS 'FIELD
                             (COND ((EQ LOCALITY 'I-MEM)
                                    (LIST 'JUMP-ADDRESS-MULTIPLIER I-MEM-LOC))
                                   ((EQ LOCALITY 'A-MEM)
                                    (LIST 'A-SOURCE-MULTIPLIER A-MEM-LOC))
                                   ((EQ LOCALITY 'M-MEM)
                                    (LIST 'M-SOURCE-MULTIPLIER M-MEM-LOC))
                                   ((EQ LOCALITY 'D-MEM)
                                    (LIST 'DISPATCH-ADDRESS-MULTIPLIER D-MEM-LOC))
                                   (T (CONS-LAP-BARF LOCALITY
                                                     'BAD-LOCALITY
                                                     'BARF))) )) )
               (COND ((OR (EQ LOCALITY 'M-MEM)          ;automatically MC-LINKAGEify
                          (AND (EQ LOCALITY 'A-MEM)     ; accumulator type frobs.
                               (< A-MEM-LOC 40)))
                      (CONS-LAP-MC-LINKAGE-STORE WD))))
              ((EQ (CAR WD) 'BEGIN-COMMENT)
               (SETQ CONS-LAP-INSIDE-COMMENT T))
              ((EQ (CAR WD) 'DEF-DATA-FIELD)
                (DEF-DATA-FIELD (CADR WD)
                                (CONS-LAP-ARG-EVAL (CADDR WD))
                                (CONS-LAP-ARG-EVAL (CADDDR WD))))
              ((EQ (CAR WD) 'DEF-BIT-FIELD-IN-REG)
                (DEF-BIT-FIELD-IN-REG (CADR WD)
                                      (CONS-LAP-ARG-EVAL (CADDR WD))
                                      (CONS-LAP-ARG-EVAL (CADDDR WD))
                                      (CAR (CDDDDR WD))))
              ((EQ (CAR WD) 'ASSIGN)
                (CONS-LAP-DEFSYM (CADR WD)
                                 (CADDR WD)))
              ((EQ (CAR WD) 'ASSIGN-EVAL)
                (CONS-LAP-DEFSYM (CADR WD)
                                 (CONS-LAP-ARG-EVAL (CADDR WD))))
              ((EQ (CAR WD) 'DEF-NEXT-BIT)
                (DEF-NEXT-FIELD (CADR WD) 1 (CADDR WD)))
              ((EQ (CAR WD) 'RESET-BIT-POINTER)
                (RESET-BIT-POINTER (CADR WD)))
              ((EQ (CAR WD) 'DEF-NEXT-FIELD)
                (DEF-NEXT-FIELD (CADR WD)
                                (CONS-LAP-ARG-EVAL (CADDR WD))
                                (CADDDR WD)))
              ((EQ (CAR WD) 'LOCALITY)
                (SETQ LOCALITY (CADR WD))
                (COND ((NOT (MEMQ LOCALITY '(M-MEM A-MEM D-MEM I-MEM)))
                        (CONS-LAP-BARF LOCALITY 'BAD-LOCALITY 'BARF))))
              ((EQ (CAR WD) 'START-DISPATCH)
                (COND ((NOT (EQ LOCALITY 'D-MEM))
                        (CONS-LAP-BARF LOCALITY 'BAD-START-DISPATCH 'BARF)))
                (COND (IN-DISPATCH-BLOCK
                        (CONS-LAP-BARF WD 'ALREADY-IN-DISPATCH 'DATA)))
                (SETQ D-MEM-LOC (FIND-D-MEM-SPACE (EXPT 2 (CADR WD))))
                (SETQ IN-DISPATCH-BLOCK T))
              ((EQ (CAR WD) 'END-DISPATCH)
                (COND ((NULL IN-DISPATCH-BLOCK)
                        (CONS-LAP-BARF WD 'NOT-IN-DISPATCH-BLOCK 'DATA)))
                (COND ((> D-MEM-LOC DISPATCH-BLOCK-LIMIT)
                        (CONS-LAP-BARF D-MEM-LOC
                                       'DISPATCH-BLOCK-OVERFLOW
                                       'DATA))
                      ((NOT (= D-MEM-LOC DISPATCH-BLOCK-LIMIT))
                        (CONS-LAP-BARF (LIST D-MEM-LOC DISPATCH-BLOCK-LIMIT)
                              'DISPATCH-BLOCK-UNDERFLOW
                              'WARN)))
                (SETQ IN-DISPATCH-BLOCK NIL))
              ((MEMQ (CAR WD) '(LOC MODULO))
                (CONS-LAP-LOC-MODULO WD))
              ((EQ (CAR WD) 'REPEAT)
                (CONS-LAP-REPEAT-1 (CONS-LAP-ARG-EVAL (CADR WD))
                                   (CDDR WD)))
              ((MEMQ (CAR WD) '(MISC-INST-ENTRY MC-LINKAGE MC-LINKAGE-VALUE
                                MICRO-CODE-ILLEGAL-ENTRY-HERE ERROR-TABLE
                                MC-ENTRY-ADR MISC-ENTRY-ADR))
                (GO X))
              ((EQ (CAR WD) 'COMMENT))
              ((EQ (CAR WD) 'IF)
               (COND ((EVAL (CADR WD))
                      (CONS-LAP-PASS1 (CADDR WD)))
                     (T (MAPC (FUNCTION CONS-LAP-PASS1) (CDDDR WD)))))
              (T (CONS-LAP-PASS1-WD WD)
                 (GO W1)))
X       (RETURN NIL)
W1      (SETQ CONS-LAP-WDS-SINCE-LAST-SYM (1+ CONS-LAP-WDS-SINCE-LAST-SYM))
        (COND ((EQ LOCALITY 'A-MEM)
                (SETQ A-MEM-LOC (1+ A-MEM-LOC)))
              ((EQ LOCALITY 'M-MEM)
                (SETQ M-MEM-LOC (1+ M-MEM-LOC)))
              ((EQ LOCALITY 'D-MEM)
                (COND ((NOT IN-DISPATCH-BLOCK)
                        (CONS-LAP-BARF WD 'STORAGE-WD-NOT-IN-DISPATCH-BLOCK 'DATA)))
                (SETQ D-MEM-LOC (1+ D-MEM-LOC)))
              ((EQ LOCALITY 'I-MEM)
                (SETQ I-MEM-LOC (1+ I-MEM-LOC)))
              (T (CONS-LAP-BARF WD 'STORAGE-WD-IN-BAD-LOCALITY 'DATA)))
        (RETURN NIL)))

(DEFUN CONS-LAP-LOC-MODULO (WD)
   ((LAMBDA (POINT ITEM)
        (AND (EQ (CAR WD) 'MODULO)
             (SETQ ITEM (* ITEM (CEILING (SYMEVAL POINT) ITEM))))
        (AND (< ITEM (SYMEVAL POINT))
             (CONS-LAP-BARF WD 'BACKWARDS 'DATA))
        (AND (EQ LOCALITY 'D-MEM)
             (CONS-LAP-D-MEM-LOC ITEM))
        (AND (NULL A-CONSTANT-BASE)     ;ON PASS 1
             (EQ LOCALITY 'A-MEM)       ;KLUDGE TO USE SKIPPED AREA FOR CONSTANTS
             (DO I A-MEM-LOC (1+ I) (= I ITEM)
                (OR (< I 40)
                    (SETQ A-MEM-CREVICE-LIST (CONS I A-MEM-CREVICE-LIST)))))
        (SET POINT ITEM))
     (CDR (ASSQ LOCALITY '((A-MEM . A-MEM-LOC)
                           (M-MEM . M-MEM-LOC)
                           (D-MEM . D-MEM-LOC)
                           (I-MEM . I-MEM-LOC))))
     (CADR WD)))

;ALLOCATE ONE D-MEM WORD AT A SPECIFIC ADDRESS
(DEFUN CONS-LAP-D-MEM-LOC (L)
  (OR CONS-LAP-PASS2
      (DO ((BL D-MEM-FREE-BLOCKS (CDR BL))
           (TEM))
          ((NULL (CDR BL)) (BREAK "CONS-LAP-D-MEM-LOC"))
        (SETQ TEM (CADR BL))                            ;A BLOCK
        (COND ((AND (NOT (< L (CDR TEM)))               ;IF LOC IS IN THIS BLOCK
                    (< L (+ (CDR TEM) (CAR TEM))))
               (RPLACD BL (CDDR BL))                    ;PATCH OUT THIS BLOCK
               (CONS-LAP-D-MEM-LOC-SPLITUP BL (CDR TEM) L)      ;INSTALL BLOCKS BEFORE LOC
               (CONS-LAP-D-MEM-LOC-SPLITUP BL (1+ L)    ;INSTALL BLOCKS AFTER LOC
                                           (+ (CAR TEM) (CDR TEM)))
               (RETURN NIL)))))
  (SETQ D-MEM-LOC L
        IN-DISPATCH-BLOCK T
        DISPATCH-CONSTANT 0     ;DONT ADD ANYTHING TO THIS ONE.
        DISPATCH-BLOCK-LIMIT (1+ L)))

;SPLIT UP INTO POWER OF 2 BLOCKS
;******* KNOWS THAT D MEM IS 4000 LOCATIONS *******
(DEFUN CONS-LAP-D-MEM-LOC-SPLITUP (BL LOW HIGH)
  (DECLARE (FIXNUM LOW HIGH))
  (PROG (BLOCKSIZE)
    (DECLARE (FIXNUM BLOCKSIZE))
RCR (COND ((= LOW HIGH) (RETURN NIL)))
                 ;COMPUTE LARGEST POWER OF 2 BLOCK STARTING AT LOW
    (SETQ BLOCKSIZE (BOOLE 1 (+ 4000 LOW) (- 4000 LOW)))
A   (COND ((> (+ LOW BLOCKSIZE) HIGH)
           (SETQ BLOCKSIZE (TRUNCATE BLOCKSIZE 2))
           (GO A)))
    (RPLACD BL (CONS (CONS BLOCKSIZE LOW) (CDR BL)))    ;PUT IN THIS BLOCK
    (SETQ BL (CDR BL)   ;DO THE REMAINDER
          LOW (+ LOW BLOCKSIZE))
    (GO RCR)))

(DEFUN CONS-LAP-REPEAT-1 (COUNT LST)
 (PROG (ORPCNT RPCNT)
        (SETQ ORPCNT (CONS-LAP-SYMEVAL 'REPEAT-COUNT))
        (SETQ RPCNT 0)
L       (COND ((ZEROP COUNT)
               (CONS-LAP-SET 'REPEAT-COUNT ORPCNT)
               (RETURN NIL)))
        (CONS-LAP-SET 'REPEAT-COUNT RPCNT)
        (MAPC (FUNCTION (LAMBDA (X) (CONS-LAP-PASS1 (COND ((ATOM X) (LIST X))
                                                          (T X)))))
              LST)
        (SETQ COUNT (1- COUNT))
        (SETQ RPCNT (1+ RPCNT))
        (GO L)))

(DEFUN CONS-LAP-PASS1-WD (WD)
  (PROG ()
 L      (COND ((ATOM WD) (RETURN NIL))
              ((ATOM (CAR WD)))                 ;FLUSH
              ((MEMQ (CAAR WD)
                     '(ARG-CALL ARG-JUMP ARG-CALL-XCT-NEXT ARG-JUMP-XCT-NEXT))
                (SETQ ARG-CALL-LIST
                        (CONS (CONS I-MEM-LOC (FIND-D-MEM-SPACE 1))
                              ARG-CALL-LIST)))
              ((MEMQ (CAAR WD) '(OA-LOW-CONTEXT OA-HI-CONTEXT))
                (CONS-LAP-PASS1-WD (CDAR WD))))
        (SETQ WD (CDR WD))
        (GO L)))

(DEFUN FIND-D-MEM-SPACE (L)
  (PROG (B P S)
  L0    (SETQ S 20000)  ;SIZE OF BEST BLOCK TO SPLIT SO FAR
        (SETQ P D-MEM-FREE-BLOCKS)
  L     (COND ((NULL (CDR P)) (GO S))
              ((= L (CAADR P))
                (GO X))
              ((AND (> (CAADR P) L)
                    (< (CAADR P) S))
                (SETQ B P)
                (SETQ S (CAADR P))))
        (SETQ P (CDR P))
        (GO L)
  X     (SETQ B (CADR P))
        (RPLACD P (CDDR P))
        (SETQ DISPATCH-BLOCK-LIMIT (+ (CAR B) (CDR B)))
        (RETURN (CDR B))
  S     (COND ((NULL B)
                (CONS-LAP-BARF L 'OUT-OF-D-MEM 'BARF)))
        (RPLACA (CADR B) (LSH S -1))
        (RPLACD D-MEM-FREE-BLOCKS
                (CONS (CONS (LSH S -1)
                            (+ (LSH S -1) (CDADR B)))
                      (CDR D-MEM-FREE-BLOCKS)))
        (SETQ B NIL)
        (GO L0) ))

(DEFUN CONS-LAP-DEFSYM (SYM VAL)
  (PROG (TM)
        (COND ((SETQ TM (CONS-LAP-SYMEVAL SYM))
                (COND ((NOT (EQUAL VAL TM))
                        (CONS-LAP-BARF (LIST VAL TM) 'MULT-DEF-SYM 'DATA))))
              (T (PUTPROP SYM VAL 'CONS-LAP-USER-SYMBOL)))
        (RETURN NIL)))

(DEFUN CONS-LAP-SET (SYM VAL)
  (PUTPROP SYM VAL 'CONS-LAP-USER-SYMBOL))

(DEFUN CONS-LAP-SYMEVAL (SYM)
  (OR (GET SYM 'CONS-LAP-SYM) (GET SYM 'CONS-LAP-USER-SYMBOL)))

(DEFUN CONS-LAP-LISP-SYMEVAL (SYM)
  (OR (BOUNDP SYM) (FERROR NIL "Unbound Lisp Variable ~s" SYM))
  (SYMEVAL SYM))

(DEFUN DEF-DATA-FIELD (SYM BITS BITS-OVER)
  (PROG ()
        (CONS-LAP-DEFSYM SYM
          (LIST 'M-MEM (LIST 'BYTE-FIELD BITS BITS-OVER)))
        (RETURN NIL)))

(DEFUN DEF-BIT-FIELD-IN-REG (SYM BITS BITS-OVER REG)
  (PROG ()
        (CONS-LAP-DEFSYM SYM
          (LIST 'PLUS
                (LIST 'BYTE-FIELD BITS BITS-OVER)
                REG))
        (RETURN NIL)))


(DEFUN RESET-BIT-POINTER (SYM)
  (PROG ()
        (PUTPROP SYM 0 'CONS-LAP-B-PTR)))

(DEFUN DEF-NEXT-FIELD (SYM BITS IN-SYM)
  (PROG (B-PTR IN-SYM-V N-B-PTR)
        (COND ((NOT (ATOM IN-SYM))
                (CONS-LAP-BARF IN-SYM 'BAD-NEXT-FIELD 'DATA)
                (RETURN NIL)))
        (SETQ B-PTR (COND ((GET IN-SYM 'CONS-LAP-B-PTR))
                          (T '0)))
        (COND ((NULL (SETQ IN-SYM-V (CONS-LAP-SYMEVAL IN-SYM)))
                (CONS-LAP-BARF IN-SYM 'UNDEF-IN-DEF-NEXT-FIELD 'DATA)
                (RETURN NIL)))
        (COND ((> (SETQ N-B-PTR (+ BITS B-PTR)) 32.)
                (CONS-LAP-BARF IN-SYM 'OUT-OF-BITS 'DATA)
                (RETURN NIL)))
        (CONS-LAP-DEFSYM SYM (LIST 'PLUS (LIST 'BYTE-FIELD BITS B-PTR)
                                   IN-SYM-V))
        (PUTPROP IN-SYM N-B-PTR 'CONS-LAP-B-PTR)
))

(DEFUN CONS-LAP-PASS2 (WD)
  (PROG (V)
        (COND (CONS-LAP-INSIDE-COMMENT
               (WHEN (EQUAL WD '(END-COMMENT))
                 (SETQ CONS-LAP-INSIDE-COMMENT NIL))
               (RETURN NIL))
              ((ATOM WD)
               (SETQ CONS-LAP-LAST-SYM WD)
               (SETQ CONS-LAP-WDS-SINCE-LAST-SYM 0)
               (COND ((AND DISPATCH-ARM
                           (EQ LOCALITY 'D-MEM))
                      (SETQ D-MEM-LOC (LDB 1413 (CONS-LAP-ARG-EVAL WD)))
                      (SETQ DISPATCH-ARM NIL))
                     ((NOT (EQUAL
                            (CONS-LAP-SYMEVAL WD)
                            (LIST LOCALITY
                                  (CONS 'FIELD
                                        (COND ((EQ LOCALITY 'I-MEM)
                                               (LIST 'JUMP-ADDRESS-MULTIPLIER I-MEM-LOC))
                                              ((EQ LOCALITY 'A-MEM)
                                               (LIST 'A-SOURCE-MULTIPLIER A-MEM-LOC))
                                              ((EQ LOCALITY 'M-MEM)
                                               (LIST 'M-SOURCE-MULTIPLIER M-MEM-LOC))
                                              ((EQ LOCALITY 'D-MEM)
                                               (LIST 'DISPATCH-ADDRESS-MULTIPLIER D-MEM-LOC))
                                              (T (CONS-LAP-BARF LOCALITY
                                                                'BAD-LOCALITY
                                                                'BARF))) )) ))
                      (CONS-LAP-BARF WD 'DEF-DFRS-ON-PASS2 'BARF))))
              ((EQ (CAR WD) 'BEGIN-COMMENT)
               (SETQ CONS-LAP-INSIDE-COMMENT T))
              ((MEMQ (CAR WD) '(DEF-DATA-FIELD ASSIGN ASSIGN-EVAL DEF-NEXT-BIT
                                               RESET-BIT-POINTER
                                               DEF-NEXT-FIELD END-DISPATCH
                                               DEF-BIT-FIELD-IN-REG)))
              ((EQ (CAR WD) 'LOCALITY)
               (SETQ LOCALITY (CADR WD)))
              ((EQ (CAR WD) 'START-DISPATCH)
               (SETQ DISPATCH-CONSTANT (COND ((CONS-LAP-ARG-EVAL (CADDR WD)))
                                             (T 0)))
               (SETQ DISPATCH-ARM T))   ;SET D-MEM-LOC TO NEXT D-MEM SYMBOL ENCOUNTERED
                                        ;ERROR IF STORAGE WORD BEFORE THAT.
              ((MEMQ (CAR WD) '(LOC MODULO))
               (CONS-LAP-LOC-MODULO WD))
              ((EQ (CAR WD) 'REPEAT)
               (CONS-LAP-REPEAT-2 (CONS-LAP-ARG-EVAL (CADR WD))
                                  (CDDR WD)))
              ((EQ (CAR WD) 'MISC-INST-ENTRY)
               (LET ((OPCODE (GET (CADR WD) 'QLVAL)))
                 (COND ((NULL OPCODE)
                        (CONS-LAP-BARF (CADR WD) 'NO-UCODE-ENTRY-INDEX 'WARN))
                       (T
                         (SETQ CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY
                               (MAX OPCODE CURRENT-ASSEMBLY-HIGHEST-MISC-ENTRY))
                         (COND ((NULL CONS-LAP-INIT-STATE)
                                (SETF (AREF MICRO-CODE-SYMBOL-IMAGE (- OPCODE 200))
                                      I-MEM-LOC))
                               (T (SETQ CURRENT-ASSEMBLY-MICRO-ENTRIES;in incremental assembly
                                        (CONS (LIST 'MISC-INST-ENTRY (CADR WD) I-MEM-LOC)
                                              CURRENT-ASSEMBLY-MICRO-ENTRIES))))))))
              ((EQ (CAR WD) 'MICRO-CODE-ILLEGAL-ENTRY-HERE)
               (SETQ MICRO-CODE-SYMBOL-TABLE-FILL-VALUE I-MEM-LOC)
               (CONS-LAP-WIPE-SYMBOL-VECTOR I-MEM-LOC))
              ((AND (EQ (CAR WD) 'MC-LINKAGE)
                    (LISTP (CADR WD)))
               (MAPC (FUNCTION CONS-LAP-MC-LINKAGE-STORE) (CADR WD)))
              ((EQ (CAR WD) 'ERROR-TABLE)
               (SETQ CURRENT-ASSEMBLY-TABLE
                     (NCONC CURRENT-ASSEMBLY-TABLE
                            (LIST (CONS (1- I-MEM-LOC) (CDR WD))))))
              ((EQ (CAR WD) 'COMMENT))
              ((EQ (CAR WD) 'IF)
               (COND ((EVAL (CADR WD))
                      (CONS-LAP-PASS2 (CADDR WD)))
                     (T (MAPC (FUNCTION CONS-LAP-PASS2) (CDDDR WD)))))
              (T (GO W1)))
     X  (RETURN NIL)
     W1 (SETQ CONS-LAP-WDS-SINCE-LAST-SYM (1+ CONS-LAP-WDS-SINCE-LAST-SYM))
        (COND (DISPATCH-ARM
               (CONS-LAP-BARF WD 'STORAGE-WD-IN-UNLOCATED-DISPATCH-BLOCK 'DATA)))
        (SETQ V (CONS-WORD-EVAL WD))
        (COND ((EQ LOCALITY 'A-MEM)
               (COND ((>= A-MEM-LOC (ARRAY-ACTIVE-LENGTH A-MEM))
                      (CONS-LAP-BARF A-MEM-LOC 'A-MEM-OVERFLOW 'DATA))
                     ((>= A-MEM-LOC 40)         ;The rest is really m-memory.
                      (SETF (AREF A-MEM A-MEM-LOC) V)))
               (SETQ A-MEM-LOC (1+ A-MEM-LOC)))
              ((EQ LOCALITY 'M-MEM)
               (COND ((< M-MEM-LOC 40)
                      (SETF (AREF A-MEM M-MEM-LOC) V))
                     (T (CONS-LAP-BARF M-MEM-LOC 'M-MEM-OVERFLOW 'DATA)))
               (SETQ M-MEM-LOC (1+ M-MEM-LOC)))
              ((EQ LOCALITY 'D-MEM)
               (SETQ V (+ V DISPATCH-CONSTANT)) ;CONSTANT FOR ENTIRE BLOCK
               (SETQ V (+ (LSH (LDB 703 V) 14.) ;RPN BITS FROM JUMP
                          (LDB 1416 V)))                ;PC FROM JUMP
               (SETF (AREF D-MEM D-MEM-LOC) V)
               (SETQ D-MEM-LOC (1+ D-MEM-LOC)))
              ((EQ LOCALITY 'I-MEM)
               (IF ( I-MEM-LOC (ARRAY-ACTIVE-LENGTH I-MEM))
                   (CONS-LAP-BARF I-MEM-LOC 'I-MEM-OVERFLOW 'DATA)
                 (SETF (AREF I-MEM I-MEM-LOC) V))
               (SETQ I-MEM-LOC (1+ I-MEM-LOC)))
              (T (CONS-LAP-BARF WD 'STORAGE-WD-IN-BAD-LOCALITY 'DATA)))
        (RETURN NIL)
        ))

;add symbol to MC-LINKAGE-ALIST
(DEFUN CONS-LAP-MC-LINKAGE-STORE (ELEM)
  (PROG (MC-SYM CONSLP-SYM VAL TEM TYPE)
        (COND ((ATOM ELEM)
               (SETQ MC-SYM ELEM CONSLP-SYM ELEM))
              (T (SETQ MC-SYM (CAR ELEM) CONSLP-SYM (CADR ELEM))))
        (SETQ VAL (GET CONSLP-SYM 'CONS-LAP-USER-SYMBOL))
    L   (COND ((NULL VAL) (RETURN NIL))
              ((NUMBERP VAL))
              ((ATOM VAL)
                (SETQ VAL (CONS-LAP-SYMEVAL VAL))
                (SETQ TYPE 'N)
                (GO L))
             ((AND (SETQ TEM (ASSQ (CAR VAL)
                        '( (I-MEM JUMP-ADDRESS-MULTIPLIER I)
                           (D-MEM DISPATCH-ADDRESS-MULTIPLIER D)
                           (A-MEM A-SOURCE-MULTIPLIER A)
                           (M-MEM M-SOURCE-MULTIPLIER M))))
                   (EQ (CAADR VAL) 'FIELD)
                   (EQ (CADADR VAL) (CADR TEM)))
              (SETQ VAL (CADDR (CADR VAL)))
              (SETQ TYPE (CADDR TEM)))
             (T (RETURN NIL)))
        (SETQ MC-LINKAGE-ALIST (CONS (LIST MC-SYM TYPE VAL) MC-LINKAGE-ALIST))
        ))



;define MC-LINKAGE symbol as regular symbol
(DEFUN CONS-LAP-DEFINE-LINKAGE-SYMBOL (SYMBOL)
  (CONS-LAP-DEFSYM SYMBOL (CONS-LAP-MC-LINKAGE SYMBOL)))

;(MC-LINKAGE <SYMBOL>)
(DEFUN CONS-LAP-MC-LINKAGE (SYMBOL)
  (PROG (TEM V MULT MEM)
        (COND ((NULL (SETQ TEM (ASS (FUNCTION STRING-EQUAL) SYMBOL MC-LINKAGE-ALIST)))
               (FERROR NIL "~%Undefined MC-LINKAGE symbol ~S" SYMBOL)))
        (SETQ MEM (STRING (CADR TEM)) V (CADDR TEM))
        (COND ((STRING-EQUAL MEM "N") (GO X))
              ((SETQ TEM (ASS (FUNCTION STRING-EQUAL) MEM
                              '( ("I" JUMP-ADDRESS-MULTIPLIER I-MEM)
                                ("D" DISPATCH-ADDRESS-MULTIPLIER D-MEM)
                                ("A" A-SOURCE-MULTIPLIER A-MEM)
                                ("M" M-SOURCE-MULTIPLIER M-MEM))))
               (SETQ MULT (CADR TEM) MEM (CADDR TEM)))
              (T (FERROR NIL "~%Unknown memory name ~S" MEM)))
        (SETQ V `(,MEM (FIELD ,MULT ,V)))
    X   (RETURN V)
))

;(MC-LINKAGE-VALUE <MEMORY> <SYMBOL>)
(DEFUN CONS-LAP-MC-LINKAGE-VALUE (MEMORY SYMBOL)
  (PROG (V MULT)
        (COND ((NULL (SETQ V (ASS (FUNCTION STRING-EQUAL) SYMBOL MC-LINKAGE-ALIST)))
               (FERROR NIL "~%Undefined MC-LINKAGE symbol ~S" SYMBOL)))
        (SETQ V (CADDR V))
        (COND ((STRING-EQUAL MEMORY "NUMBER") (GO X))
              ((SETQ MULT (ASS (FUNCTION STRING-EQUAL) MEMORY
                               '( ("I-MEM" . JUMP-ADDRESS-MULTIPLIER)
                                  ("D-MEM" . DISPATCH-ADDRESS-MULTIPLIER)
                                  ("A-MEM" . A-SOURCE-MULTIPLIER)
                                  ("M-MEM" . M-SOURCE-MULTIPLIER))))
               (SETQ MULT (CDR MULT)))
              (T (FERROR NIL "~%Unknown memory name ~S" MEMORY)))
        (SETQ V `(FIELD ,MULT ,V))
    X   (RETURN V)
))

(DEFUN CONS-LAP-WIPE-SYMBOL-VECTOR (QUAN)
  (PROG (IDX END-TEST)
        (SETQ IDX 0)
        (SETQ END-TEST (ARRAY-LENGTH MICRO-CODE-SYMBOL-IMAGE))
     L  (COND ((NOT (< IDX END-TEST))
               (RETURN T))
              ((NULL (AREF MICRO-CODE-SYMBOL-IMAGE IDX))
               (SETF (AREF MICRO-CODE-SYMBOL-IMAGE IDX) QUAN)))
        (SETQ IDX (1+ IDX))
        (GO L)))

(DEFUN CONS-LAP-REPEAT-2 (COUNT LST)
  (PROG (ORPCNT RPCNT)
        (SETQ ORPCNT (CONS-LAP-SYMEVAL 'REPEAT-COUNT))
        (SETQ RPCNT 0)
     L  (COND ((ZEROP COUNT)
               (CONS-LAP-SET 'REPEAT-COUNT ORPCNT)
               (RETURN NIL)))
        (CONS-LAP-SET 'REPEAT-COUNT RPCNT)
        (MAPC (FUNCTION (LAMBDA (X) (CONS-LAP-PASS2 (COND ((ATOM X) (LIST X))
                                                          (T X)))))
              LST)
        (SETQ COUNT (1- COUNT))
        (SETQ RPCNT (1+ RPCNT))
        (GO L)))

(DEFUN CONS-WORD-EVAL (WD)
  (PROG (COMBINED-VALUE COMBINED-INDICATORS DESTINATION-CONTEXT
                        INSTRUCTION-CONTEXT FIELD-INDICATORS FIELD-VALUE TEM TEM1 TEM2
                        DESTINATION-INDICATORS CURRENT-WORD)
        (SETQ COMBINED-VALUE 0)         ;CAUTION! COMBINED-VALUE CAN BE A BIGNUM
        (SETQ CURRENT-WORD WD)          ;SO CAN SEE IT WHEN STUFF COMPILED
        (SETQ INSTRUCTION-CONTEXT 'INSTRUCTION)
     L  (SETQ FIELD-INDICATORS NIL)
        (COND ((NULL WD) (RETURN
                          (CONS-LAP-DEFAULT-AND-BUGGER
                           INSTRUCTION-CONTEXT
                           COMBINED-VALUE
                           COMBINED-INDICATORS
                           DESTINATION-INDICATORS)))
              ((NUMBERP (CAR WD))
               (SETQ FIELD-VALUE (CAR WD)))
              ((ATOM (CAR WD))
               (SETQ FIELD-VALUE (CONS-LAP-SYM-RUN (CAR WD))))
              ((EQ (CAAR WD) 'M-CONSTANT)
               (SETQ FIELD-VALUE (CONS-M-CONSTANT (CADAR WD))))
              ((EQ (CAAR WD) 'A-CONSTANT)
               (SETQ FIELD-VALUE (CONS-A-CONSTANT (CADAR WD))))
              ((SETQ TEM
                     (ASSQ (CAAR WD)
                           '((ARG-CALL . 3_14.)              ;P-BIT N-BIT
                             (ARG-JUMP . 1_14.)              ;N-BIT
                             (ARG-CALL-XCT-NEXT . 2_14.)     ;P-BIT
                             (ARG-JUMP-XCT-NEXT . 0_14.) ))) ; NONE
               (SETQ TEM1 (CONS-LAP-ARG-EVAL (CADAR WD))) ;TAG
               (SETQ TEM2 (ASSOC I-MEM-LOC ARG-CALL-LIST))
               (COND ((NULL TEM2)
                      (CONS-LAP-BARF I-MEM-LOC
                                     'NO-D-MEM-RESERVED-FOR-ARG-CALL
                                     'BARF)))
               (SETF (AREF D-MEM (CDR TEM2))
                     (+ (CDR TEM) (LDB 1416 TEM1)))
               (CONS-GET-NEW-CONTEXT 'FORCE-DISPATCH)
               (ADD-FIELD-INDICATORS 'D-MEM)
               (SETQ FIELD-VALUE (* (CDR TEM2) 1_12.)))
              ((MEMQ (CAAR WD) '(BYTE-FIELD LISP-BYTE ALL-BUT-LISP-BYTE
                                            FIELD BYTE-MASK BYTE-VALUE PLUS DIFFERENCE
                                            OA-HIGH-CONTEXT OA-LOW-CONTEXT EVAL I-ARG
                                            I-MEM-LOC D-MEM-LOC A-MEM-LOC M-MEM-LOC
                                            MC-LINKAGE MC-LINKAGE-VALUE
                                            MC-ENTRY-ADR MISC-ENTRY-ADR))
               (SETQ FIELD-VALUE (CONS-LAP-EVAL (CAR WD))))
              (T
               (CONS-GET-NEW-CONTEXT 'FORCE-ALU-OR-BYTE)
               (SETQ FIELD-VALUE (CONS-DESTINATION (CAR WD)))

               (SETQ FIELD-VALUE
                     (CONVERT-VALUE-TO-DESTINATION FIELD-VALUE FIELD-INDICATORS))
               (SETQ DESTINATION-INDICATORS FIELD-INDICATORS)
               (SETQ FIELD-INDICATORS NIL)) )
        (SETQ COMBINED-VALUE (PLUS COMBINED-VALUE FIELD-VALUE))
;       (PRINT (LIST (CAR WD) FIELD-VALUE FIELD-INDICATORS))
        (SETQ COMBINED-INDICATORS (MERGE-INDICATORS
                                   FIELD-INDICATORS COMBINED-INDICATORS))
        (SETQ WD (CDR WD))
        (GO L)
        ))

(DEFUN CONS-LAP-DEFAULT-AND-BUGGER
         (INSTRUCTION-CONTEXT COMBINED-VALUE COMBINED-INDICATORS DESTINATION-INDICATORS)
  (PROG (T1 T2 INST)
;       (PRINT (LIST INSTRUCTION-CONTEXT
;                    COMBINED-VALUE
;                    COMBINED-INDICATORS
;                    DESTINATION-INDICATORS))
        (COND ((NOT (EQ LOCALITY 'I-MEM))
               (GO X))
              ((MEMQ INSTRUCTION-CONTEXT '(FORCE-ALU FORCE-ALU-OR-BYTE INSTRUCTION))
               (GO ALU))
              ((EQ INSTRUCTION-CONTEXT 'FORCE-DISPATCH)
               (GO DISPATCH))
              ((EQ INSTRUCTION-CONTEXT 'FORCE-BYTE)
               (GO BYTE))
              ((EQ INSTRUCTION-CONTEXT 'FORCE-JUMP)
               (GO JUMP))
              (T (CONS-LAP-BARF (LIST INSTRUCTION-CONTEXT
                                      COMBINED-VALUE COMBINED-INDICATORS
                                      DESTINATION-INDICATORS)
                                'BAD-INSTRUCTION-TYPE
                                'WARN)
                 (GO X)))
    ALU (COND ((NULL (MEMQ 'ALU-OUTPUT-BUS-SELECTOR-MULTIPLIER  ;DEFAULT OUTPUT BUS
                           COMBINED-INDICATORS))                ;SELECTOR IF NOT SPECD
               (SETQ COMBINED-VALUE (PLUS COMBINED-VALUE 1_12.))))
        (COND ((MEMQ 'ALU-OP COMBINED-INDICATORS)
               (GO ALU-1)))
        (SETQ T1 (MEMQ 'A-MEM COMBINED-INDICATORS))             ;DEFAULT ALU OP IF NOT
        (SETQ T2 (MEMQL '(M-MEM FUNCTION-SOURCE) COMBINED-INDICATORS))  ;SPECD
        (COND ((AND T1 T2)                      ;(ALU MUST BE ACTING AS A SELECTOR)
               (CONS-LAP-BARF COMBINED-INDICATORS
                              'ALU-INST-ADRS-A-AND-M-WITHOUT-ALU-OP
                              'WARN))
              (T1 (SETQ COMBINED-VALUE
                        (PLUS COMBINED-VALUE 5_3)))     ;SETA
              (T2 (SETQ COMBINED-VALUE
                        (PLUS COMBINED-VALUE 3_3)))     ;SETM
              (T  (SETQ COMBINED-VALUE
                        (PLUS COMBINED-VALUE 0_3))))    ;NEITHER SPECD? SETZ I GUESS
     ALU-1
       (GO X)
     BYTE
       (COND ((NULL (MEMQ 'A-MEM COMBINED-INDICATORS))  ;DEFAULT A-MEM ADR TO
              (SETQ COMBINED-VALUE                      ;A-ZERO IF NOT SUPPLIED,
                    (PLUS COMBINED-VALUE 2_32.)))) ;THIS RIGHT FOR BOTH LDB AND DPB
       (SETQ INST 600000000000000)                      ;BYTE INST
       (SETQ T1 (LDB 1401 COMBINED-VALUE))      ;GET SR-BIT
       (SETQ COMBINED-VALUE (DPB (- 1 T1) ;STORE IT BACK COMPLEMENTED
                                    1401 COMBINED-VALUE))
       (COND ((> (LDB 1402 COMBINED-VALUE) 1)
              (GO X1))) ;DONT BUGGER DPB OR SEL DEPOS
     M-ROTATE-BUGGER                            ;32. REFLECT M-ROTATE FIELD
       (SETQ T1 (LOGAND 6037 COMBINED-VALUE))   ;GOBBLE MISC FCTN
       ;AND M-ROTATE
     M-ROTATE-BUGGER-1
       (SETQ T1 (LOGAND 37 T1))
       (SETQ T2 (LOGAND 37 (- 40 T1)))
       (SETQ COMBINED-VALUE (PLUS COMBINED-VALUE (- T2 T1)))
     X1 (SETQ COMBINED-VALUE (PLUS COMBINED-VALUE INST))
     X  (RETURN COMBINED-VALUE)
     DISPATCH
       (SETQ INST 1400000000000000)     ;DISPATCH INSTRUCTION PLUS I-LONG
       ;(SETQ INST 400000000000000)     ;JUST DISPATCH INSTRUCTION
       (GO M-ROTATE-BUGGER)
     JUMP
       (SETQ INST 200000000000000)
       (SETQ T1 (LOGAND 6077 COMBINED-VALUE))
       (COND ((> (LOGAND T1 77) 37) (GO X1)))   ;TEST-CONDITION, DONT HACK
       (GO M-ROTATE-BUGGER-1)           ;RANDOMLY SAVE A BIGNUM OP
       ))

;CONSTANT LISTS.
;A LIST OF LISTS.  CAR IS VALUE OF CONSTANT, CADR IS ADDRESS, CADDR IS #USERS, CADDDR IS
;       LAST PC TO USE IT.

(DEFUN CONS-M-CONSTANT (C)
  (PROG (TEM V)
        (SETQ V (CONS-LAP-ARG-EVAL C))
        (COND ((= V 0)
                (SETQ TEM 2))   ;M LOCN 2 ALWAYS HAS 0
              ((OR (= V 37777777777) (= V -1))
               (SETQ TEM 3))    ;M LOCN 3 ALWAYS HAS -1 (TO 32 BITS)
              ((SETQ TEM (ASSOC V M-CONSTANT-LIST))
                (RPLACA (CDDR TEM) (1+ (CADDR TEM)))
                (RPLACA (CDDDR TEM) CONS-LAP-LAST-SYM)
                (SETQ TEM (CADR TEM)))
              (T
                (SETQ TEM M-CONSTANT-LOC M-CONSTANT-LOC (1+ M-CONSTANT-LOC))
                (SETQ M-CONSTANT-LIST (CONS (LIST V TEM 1 CONS-LAP-LAST-SYM) M-CONSTANT-LIST))))
        (OR (< TEM 40) (CONS-LAP-BARF (LIST TEM C) 'M-CONST-ADDR-OOB 'BARF))
        (ADD-FIELD-INDICATORS 'M-MEM)
        (RETURN (DPB TEM 3205 0)) ))

(DEFUN CONS-A-CONSTANT (C)
  (PROG (TEM V)
        (SETQ V (CONS-LAP-ARG-EVAL C))
        (COND ((= V 0)
                (SETQ TEM 2))   ;A LOCN 2 ALWAYS HAS 0
              ((OR (= V 37777777777) (= V -1))
               (SETQ TEM 3))    ;A LOCN 3 ALWAYS HAS -1 (TO 32 BITS)
              ((SETQ TEM (ASSOC V A-CONSTANT-LIST))
                (RPLACA (CDDR TEM) (1+ (CADDR TEM)))
                (RPLACA (CDDDR TEM) CONS-LAP-LAST-SYM)
                (SETQ TEM (CADR TEM)))
              ((SETQ TEM (ASSOC V M-CONSTANT-LIST))     ;A=M!!
                (RPLACA (CDDR TEM) (1+ (CADDR TEM)))
                (RPLACA (CDDDR TEM) CONS-LAP-LAST-SYM)
                (SETQ TEM (CADR TEM)))
              ((NOT (NULL A-MEM-CREVICE-LIST))  ;TRY TO FILL IN CREVICES IN MEMORY
                (SETQ TEM (CAR A-MEM-CREVICE-LIST))
                (SETQ A-MEM-CREVICE-LIST (CDR A-MEM-CREVICE-LIST))
                (SETQ A-CONSTANT-LIST (CONS (LIST V TEM 1 CONS-LAP-LAST-SYM) A-CONSTANT-LIST)))
              (T
                (SETQ TEM A-CONSTANT-LOC A-CONSTANT-LOC (1+ A-CONSTANT-LOC))
                (SETQ A-CONSTANT-LIST (CONS (LIST V TEM 1 CONS-LAP-LAST-SYM)
                                            A-CONSTANT-LIST))))
        (OR (< TEM 2000) (CONS-LAP-BARF (LIST TEM C) 'A-CONST-ADDR-OOB 'BARF))
        (ADD-FIELD-INDICATORS 'A-MEM)
        (RETURN (DPB TEM 4012 0)) ))

(DEFUN CONVERT-VALUE-TO-DESTINATION (VALUE INDICATORS)
  (PROG (V)
        (SETQ V (LDB 0012 VALUE))       ;GOBBLE BYTE INFO, IF ANY (HOPE HOPE)
        (COND ((MEMQ 'A-MEM INDICATORS)
               (COND ((MEMQL '(M-MEM FUNCTION-DESTINATION) INDICATORS)
                      (CONS-LAP-BARF (LIST VALUE INDICATORS) 'BAD-DESTINATION 'DATA)))
               (SETQ V (+ V (DPB (LDB 4012 VALUE) 1612 0))))
              ((MEMQ 'M-MEM INDICATORS)
               (SETQ V (+ V (DPB (LDB 3206 VALUE) 1606 0)))))
        (COND ((MEMQ 'FUNCTION-DESTINATION INDICATORS)
               (SETQ V (+ V (LOGAND 37_19. VALUE)))))
        (COND ((MEMQL '(A-MEM) INDICATORS)
               (SETQ V (+ V 1_25.))))
        (RETURN V)
))

(DEFUN MERGE-INDICATORS (A B) (MERGE A B))

(DEFUN MERGE (A B)
  (PROG NIL
        (COND ((NULL B) (RETURN A)))
  L     (COND ((NULL A) (RETURN B))
              ((NOT (MEMQ (CAR A) B))
                (SETQ B (CONS (CAR A) B))))
        (SETQ A (CDR A))
        (GO L)))

(DEFUN CONS-DESTINATION (X)
  (PROG (DESTINATION-CONTEXT V)
        (SETQ V 0)
        (SETQ DESTINATION-CONTEXT 'DESTINATION)
        (COND ((NULL (CDR X))   ;SAVE A PLUS IN COMMON CASE..
                (RETURN (CONS-LAP-SYM-RUN (CAR X)))))
L       (COND ((NULL X) (RETURN V)))
        (SETQ V (PLUS V (CONS-LAP-SYM-RUN (CAR X))))
        (SETQ X (CDR X))
        (GO L)
))

(DEFUN CONS-LAP-SYM-RUN (SYM)
  (PROG (TEM)
        (COND ((NULL (SETQ TEM (CONS-LAP-SYMEVAL SYM)))
                (CONS-LAP-BARF SYM 'UNDEFINED-SYM 'WARN)
                (RETURN 0))
              (T (RETURN (CONS-LAP-EVAL TEM))))))

(DEFUN CONS-LAP-ARG-EVAL (ARG)
  (PROG (COMBINED-VALUE COMBINED-INDICATORS DESTINATION-CONTEXT
         INSTRUCTION-CONTEXT FIELD-INDICATORS)
        (SETQ INSTRUCTION-CONTEXT 'INSTRUCTION)
        (RETURN (CONS-LAP-EVAL ARG))))

(DEFUN CONS-LAP-EVAL (EXP)      ;EXP A SYMBOL "PROGRAM".
                                ;RETURNS EITHER A NUMBERIC VALUE OR NIL, AND
                                ;MAY HAVE THE SIDE EFFECT OF MODIFING
                                ;INSTRUCTION-CONTEXT AND/OR FIELD-INDICATORS

  (PROG (VAL V V1 V2 TEM)
L       (COND ((NULL EXP) (GO X))
              ((NUMBERP EXP)
                (SETQ V EXP)
                (GO C-V))
              ((ATOM EXP)
                (SETQ V (CONS-LAP-SYM-RUN EXP))
                (GO C-V))
              ((MEMQ (CAR EXP) '(A-MEM M-MEM I-MEM D-MEM))
                (GO L2))
              ((EQ (CAR EXP) 'SOURCE-P) (GO S-P))
              ((EQ (CAR EXP) 'DESTINATION-P) (GO D-P))
              ((MEMQ (CAR EXP) '(FORCE-DISPATCH FORCE-JUMP FORCE-ALU FORCE-BYTE
                        FORCE-DISPATCH-OR-BYTE FORCE-ALU-OR-BYTE))
                (CONS-GET-NEW-CONTEXT (CAR EXP))
                (GO L2))
              ((SETQ TEM (ASSQ (CAR EXP) '( (DISPATCH-INSTRUCTION-P . FORCE-DISPATCH)
                (BYTE-INSTRUCTION-P . FORCE-BYTE) (JUMP-INSTRUCTION-P . FORCE-JUMP)
                (ALU-INSTRUCTION-P . FORCE-ALU))))
                (GO I-P))
              ((EQ (CAR EXP) 'NOT)
                (GO N1))
              ((EQ (CAR EXP) 'OR)
                (GO OR-1))
              ((SETQ V (ASSQ (CAR EXP)
                             '((I-MEM-LOC . I-MEM) (D-MEM-LOC . D-MEM)
                               (A-MEM-LOC . A-MEM) (M-MEM-LOC . M-MEM))))
                (SETQ TEM (CONS-LAP-SYMEVAL (CADR EXP)))
                (OR (EQ (CAR TEM) (CDR V))
                    (CONS-LAP-BARF EXP 'LOSES 'DATA))
                (SETQ V (CADDR (CADR TEM)))
                (GO C-V))
              ((EQ (CAR EXP) 'FIELD)
                (SETQ TEM (CONS-LAP-SYM-RUN (CADR EXP)))
                (SETQ V (TIMES (CONS-LAP-EVAL (CADDR EXP)) TEM))
                (COND ((SETQ TEM (GET (CADR EXP) 'CONS-LAP-ADDITIVE-CONSTANT))
                        (SETQ V (PLUS V TEM))))
                (ADD-FIELD-INDICATORS (CADR EXP))
                (GO C-V))
              ((EQ (CAR EXP) 'PLUS)
                (SETQ V (CONS-LAP-EVAL (CADR EXP)))
                (DO L (CDDR EXP) (CDR L) (NULL L)
                  (SETQ V (PLUS V (CONS-LAP-EVAL (CAR L)))))
                (GO C-V))
              ((EQ (CAR EXP) 'DIFFERENCE)
                (SETQ V (DIFFERENCE (CONS-LAP-EVAL (CADR EXP))
                                    (CONS-LAP-EVAL (CADDR EXP))))
                (GO C-V))
              ((EQ (CAR EXP) 'BYTE-FIELD)
                (COND ((MEMQ INSTRUCTION-CONTEXT '(INSTRUCTION FORCE-DISPATCH-OR-BYTE
                                                        FORCE-ALU-OR-BYTE))
                        (CONS-GET-NEW-CONTEXT 'FORCE-BYTE)))
                (SETQ V1 (CONS-LAP-EVAL (CADR EXP)) V2 (CONS-LAP-EVAL (CADDR EXP)))
                (COND ((EQ INSTRUCTION-CONTEXT 'FORCE-BYTE)
                       (AND (> V1 32.) (CONS-LAP-BARF (CADR EXP)
                                                      'BYTE-SIZE-GREATER-THAN-32
                                                      'DATA))
                       (AND (ZEROP V1) (SETQ V1 1))     ;BYTE SIZE 0, DOING OA HACKERY, USE 1-1
                       (SETQ V (+ (* 1_5. (1- V1)) V2))) ;1- BYTE SIZE, MROT NOT BUGGERED YET
                      ((EQ INSTRUCTION-CONTEXT 'FORCE-DISPATCH)
                        (AND (> V1 7) (CONS-LAP-BARF (CADR EXP)
                                                     'DISPATCH-BYTE-SIZE-GREATER-THAN-7
                                                     'DATA))
                        (SETQ V (+ (* 1_5. V1) V2)))
                      ((EQ INSTRUCTION-CONTEXT 'FORCE-JUMP)
                        (COND ((NOT (= 1 V1))
                                (CONS-LAP-BARF (CADR EXP)
                                                'CAN-ONLY-TEST-ONE-BIT-FIELD-WITH-JUMP
                                                 'DATA)))
                        (SETQ V V2))
                      (T (CONS-LAP-BARF INSTRUCTION-CONTEXT
                                        'BYTE-FIELD-IN-BAD-CONTEXT
                                        'DATA)))
                (GO C-V))
              ((EQ (CAR EXP) 'LISP-BYTE)
                (SETQ V (CONS-LAP-EVAL (CONVERT-LISP-BYTE (CADR EXP))))
                (GO C-V))
              ((EQ (CAR EXP) 'ALL-BUT-LISP-BYTE)
                (SETQ V (CONS-LAP-EVAL (CONVERT-ALL-BUT-LISP-BYTE (CADR EXP))))
                (GO C-V))
              ((EQ (CAR EXP) 'BYTE-MASK)
                (SETQ V (CONS-LAP-GET-BYTE-VALUE (CADR EXP) -1))
                (GO C-V))
              ((EQ (CAR EXP) 'BYTE-VALUE)
                (SETQ V (CONS-LAP-GET-BYTE-VALUE (CADR EXP) (CADDR EXP)))
                (GO C-V))
              ((EQ (CAR EXP) 'EVAL)
                (SETQ V (EVAL (CADR EXP)))
                (GO C-V))
              ((EQ (CAR EXP) 'I-ARG)
                (SETQ V (DPB (CONS-LAP-EVAL (CADR EXP))
                                4012
                                0))
                (GO C-V))
              ((EQ (CAR EXP) 'OA-HIGH-CONTEXT)
                (SETQ V (LDB 3226 (CONS-WORD-EVAL (CADR EXP)))) ;ALL ABOVE 26. BITS
                (GO C-V))
              ((EQ (CAR EXP) 'OA-LOW-CONTEXT)
                ;  (SETQ V (LDB 0032 (CONS-WORD-EVAL (CADR EXP)))) ;LOW 26. BITS
                   (SETQ V (LET ((TEM-V (CONS-WORD-EVAL (CADR EXP))))  ;RESULT OF LDB CANT BE
                             (DPB (LDB 2703 TEM-V) 2703 (LDB 0027 TEM-V)))) ;BIGNUM FOR NOW.
                (GO C-V))
              ((AND (EQ (CAR EXP) 'MC-LINKAGE)
                    (SYMBOLP (CADR EXP)))
               (SETQ V (CONS-LAP-EVAL (CONS-LAP-MC-LINKAGE (CADR EXP))))
               (GO C-V))
              ((EQ (CAR EXP) 'MC-LINKAGE-VALUE)
               (SETQ V (CONS-LAP-EVAL (CONS-LAP-MC-LINKAGE-VALUE (CADR EXP) (CADDR EXP))))
               (GO C-V))
              ((AND CONS-LAP-INIT-STATE         ;incremental assembly
                    (EQ (CAR EXP) 'MC-ENTRY-ADR))
               (COND ((NOT (= (%DATA-TYPE
                                (SETQ TEM (CAR (FUNCTION-CELL-LOCATION (CADR EXP)))))
                              DTP-U-ENTRY))
                (FERROR NIL "mc-entry-adr not DTP-U-ENTRY")))
               (SETQ V (CONS-LAP-EVAL
                         `(I-MEM (FIELD JUMP-ADDRESS-MULTIPLIER
                                        ,(AR-1 (FUNCTION SYS:MICRO-CODE-SYMBOL-AREA)
                                               (AR-1 (FUNCTION SYS:MICRO-CODE-ENTRY-AREA)
                                                     (%POINTER TEM)))))))
               (GO C-V))
              ((AND CONS-LAP-INIT-STATE         ;incremental assembly
                    (EQ (CAR EXP) 'MISC-ENTRY-ADR))
               (SETQ V (CONS-LAP-EVAL
                         `(I-MEM (FIELD JUMP-ADDRESS-MULTIPLIER
                                        ,(AR-1 (FUNCTION SYS:MICRO-CODE-SYMBOL-AREA)
                                               (- (GET (CADR EXP) 'QLVAL) 200))))))
               (GO C-V))
              (T (CONS-LAP-BARF EXP 'UNRECGONIZED-OP 'DATA)
                 (GO X)))
OR-2    (COND ((NULL (CDR (SETQ EXP (CDR EXP))))
                (GO X)))                                ;ALL NIL
OR-1    (SETQ TEM (CONS-LAP-EVAL (CADR EXP)))
        (COND ((NULL TEM) (GO OR-2)))   ;THAT ONE EVALUATED TO NIL
MERGE-V (COND ((NULL VAL) (SETQ VAL TEM))
              (T (SETQ VAL (PLUS VAL TEM))))
        (GO X)
N1      (SETQ TEM (CONS-LAP-EVAL (LIST (CAADR EXP) 1)))
        (COND ((= TEM 1) (GO X))   ;THAT CONDITION TRUE, THIS FALSE
              (T (SETQ EXP (CADR EXP))  ;THAT CONDITION FALSE, THIS TRUE
                 (GO L1)))
D-P     (COND (DESTINATION-CONTEXT (GO L1)))
        (GO X)
S-P     (COND (DESTINATION-CONTEXT (GO X)))
        (GO L1)

L2      (ADD-FIELD-INDICATORS (CAR EXP))
L1      (SETQ EXP (CADR EXP))
        (GO L)
I-P     (COND ((EQ (CDR TEM) INSTRUCTION-CONTEXT)
                (GO L1))                ;CONDITION TRUE
              ((EQ INSTRUCTION-CONTEXT 'INSTRUCTION)
                (CONS-LAP-BARF EXP 'UNDETERMINED-CONDITION 'WARN)))
        (GO X)          ;CONDITION FALSE
C-V     (COND ((NULL VAL) (SETQ VAL 0)))
        (COND ((NULL V)
               (CONS-LAP-BARF EXP 'EVALUATED-TO-NIL 'DATA))
              (T (SETQ VAL (PLUS VAL V))))
X       (RETURN VAL) ))

(DEFUN CONVERT-LISP-BYTE (X)  ;CONVERT LISP-BYTE TO CORRESPONDING BYTE-FIELD
  (PROG (TEM)
        (SETQ TEM (EVAL X))
        (RETURN (LIST 'BYTE-FIELD (LOGAND TEM 77)
                                  (LDB 0606 TEM)
))))

(DEFUN CONVERT-ALL-BUT-LISP-BYTE (X)    ;ADDRESS ALL BITS NOT IN BYTE. BYTE MUST BE
  (PROG (TEM BITS OVER)                 ;LEFT OR RIGHT ADJUSTED IN 32. BITS
        (SETQ TEM (EVAL X))
        (SETQ BITS (LOGAND TEM 77) OVER (LDB 0606 TEM))
        (COND ((= 0 OVER)
                (SETQ OVER BITS)
                (SETQ BITS (- 32. BITS)))
              ((= 32. (+ BITS OVER))
                (SETQ BITS (- 32. BITS))
                (SETQ OVER 0))
              (T (CONS-LAP-BARF X 'ALL-BUT-BYTE-NOT-LEFT-OR-RIGHT-ADJUSTED 'DATA)))
        (RETURN (LIST 'BYTE-FIELD BITS OVER))))

(DEFUN CONS-LAP-GET-BYTE-VALUE (EXP VAL);"EVALUATE" EXP SIMILIAR TO CONS-LAP-EVAL
  (PROG (TEM)                           ;BUT RETURN NIL FOR ANYTHING BUT BYTE-FIELD,
        (COND ((NUMBERP VAL))           ;FOR WHICH RETURN VAL IN FIELD OF BYTE
              ((NOT (ATOM VAL))
               (SETQ VAL (CONS-LAP-ARG-EVAL VAL)))
              ((SETQ TEM (CONS-LAP-SYMEVAL VAL))
               (SETQ VAL TEM))
              ((SETQ VAL (CONS-LAP-LISP-SYMEVAL VAL))))
        (COND ((NULL EXP) (RETURN NIL))
              ((NUMBERP EXP)
                (RETURN (CONS-LAP-GET-BYTE-VALUE (CONVERT-LISP-BYTE EXP) VAL)))
              ((ATOM EXP)
                (RETURN (CONS-LAP-GET-BYTE-VALUE
                          (OR (CONS-LAP-SYMEVAL EXP) (CONS-LAP-LISP-SYMEVAL EXP)) VAL)))
              ((MEMQ (CAR EXP) '(M-MEM FORCE-DISPATCH FORCE-BYTE FORCE-DISPATCH-OR-BYTE
                                 FORCE-ALU-OR-BYTE))
                (RETURN (CONS-LAP-GET-BYTE-VALUE (CADR EXP) VAL)))
              ((MEMQ (CAR EXP) '(A-MEM I-MEM D-MEM SOURCE-P DESTINATION-P FORCE-JUMP
                                FORCE-ALU NOT OR FIELD EVAL))
                (RETURN NIL))
              ((EQ (CAR EXP) 'PLUS)
                (RETURN (DO L (CDR EXP) (CDR L) (NULL L)
                          (AND (SETQ TEM (CONS-LAP-GET-BYTE-VALUE (CAR L) VAL))
                               (RETURN TEM)))))
              ((EQ (CAR EXP) 'LISP-BYTE)
                (RETURN (CONS-LAP-GET-BYTE-VALUE (CONVERT-LISP-BYTE (CADR EXP)) VAL)))
              ((EQ (CAR EXP) 'BYTE-FIELD)
                (RETURN (DPB VAL (+ (LSH (CADDR EXP) 6) (CADR EXP)) 0)))
              (T (CONS-LAP-BARF EXP 'CONS-LAP-GET-BYTE-VALUE 'WARN)))
))

(DEFUN ADD-FIELD-INDICATORS (X)
  (PROG NIL
        (COND ((AND DESTINATION-CONTEXT   ;BETTER NOT PUT IN MORE THAN ONE OF THESE
                    (MEMQ X '(A-MEM M-MEM I-MEM D-MEM))  ;SINCE GOING TO DIVIDE IT OUT.
                    (MEMQL '(A-MEM M-MEM I-MEM D-MEM) FIELD-INDICATORS))
                (GO E1)))
        (COND ((EQ X 'A-MEM)
                (GO X))
              ((EQ X 'M-MEM)
                (GO X))
              ((EQ X 'I-MEM)
                (GO ADD-I))
              ((EQ X 'D-MEM)
                (GO ADD-D))
              ((EQ X 'FORCE-DISPATCH)
                (GO F-D))
              ((EQ X 'FORCE-BYTE)
                (GO F-B))
              ((EQ X 'FORCE-ALU)
                (GO F-A))
              ((EQ X 'FORCE-JUMP)
                (GO F-J)))
   X    (COND ((NOT (MEMQ X FIELD-INDICATORS))
                (SETQ FIELD-INDICATORS (CONS X FIELD-INDICATORS))))
        (RETURN NIL)
 F-B    (COND ((MEMQL '(I-MEM D-MEM) COMBINED-INDICATORS)
                (GO E1)))
        (GO X)
 F-A    (COND ((OR (MEMQ INSTRUCTION-CONTEXT '(FORCE-DISPATCH FORCE-JUMP))
                   (MEMQL '(I-MEM D-MEM) COMBINED-INDICATORS))
                (GO E1)))
        (GO X)
 F-J
 ADD-I  (COND ((MEMQ INSTRUCTION-CONTEXT '(FORCE-DISPATCH FORCE-BYTE FORCE-ALU))
                (GO E1)))
        (GO X)
 F-D
 ADD-D  (COND ((OR (MEMQ INSTRUCTION-CONTEXT '(FORCE-JUMP FORCE-BYTE FORCE-ALU))
                   (MEMQL '(I-MEM) COMBINED-INDICATORS))  ;A-MEM OK NOW IF WRITING DRAM
                (GO E1)))
        (GO X)
  E1    (CONS-LAP-BARF (LIST X FIELD-INDICATORS COMBINED-INDICATORS)
              'INDICATOR-CONFLICT
              'DATA)
        (RETURN NIL)
))

(DEFUN MEMQL (A B)
  (PROG NIL
L       (COND ((NULL A) (RETURN NIL))
              ((MEMQ (CAR A) B) (RETURN A)))
        (SETQ A (CDR A))
        (GO L)))

(DEFUN CONS-GET-NEW-CONTEXT (NEW-CONTEXT)
  (PROG NIL
        (COND ((ATOM NEW-CONTEXT)
                (RETURN (CONS-GET-NEW-CONTEXT-1 NEW-CONTEXT))))
L       (COND ((NULL NEW-CONTEXT) (RETURN T))
              (T (CONS-GET-NEW-CONTEXT-1 (CAR NEW-CONTEXT))))
        (SETQ NEW-CONTEXT (CDR NEW-CONTEXT))
        (GO L)))

(DEFUN CONS-GET-NEW-CONTEXT-1 (NEW)
  (PROG NIL
        (COND ((OR (EQ INSTRUCTION-CONTEXT NEW)
                   (NOT (MEMQ NEW '(FORCE-DISPATCH FORCE-JUMP FORCE-ALU FORCE-BYTE
                        FORCE-DISPATCH-OR-BYTE FORCE-ALU-OR-BYTE))))
                (RETURN NIL))
              ((EQ INSTRUCTION-CONTEXT 'INSTRUCTION)
                (GO N1))
              ((AND (EQ INSTRUCTION-CONTEXT 'FORCE-BYTE)
                    (MEMQ NEW '(FORCE-DISPATCH-OR-BYTE FORCE-ALU-OR-BYTE)))
                (RETURN NIL))
              ((AND (EQ INSTRUCTION-CONTEXT 'FORCE-ALU)
                    (EQ NEW 'FORCE-ALU-OR-BYTE))
                (RETURN NIL))
              ((AND (EQ NEW 'FORCE-BYTE)
                    (MEMQ INSTRUCTION-CONTEXT
                          '(FORCE-DISPATCH-OR-BYTE FORCE-ALU-OR-BYTE)))
                (GO N1))
              ((AND (EQ NEW 'FORCE-ALU)
                    (EQ INSTRUCTION-CONTEXT 'FORCE-ALU-OR-BYTE))
                (GO N1))
              ((OR (AND (EQ INSTRUCTION-CONTEXT 'FORCE-DISPATCH-OR-BYTE)
                        (EQ NEW 'FORCE-ALU-OR-BYTE))
                   (AND (EQ NEW 'FORCE-ALU-OR-BYTE)
                        (EQ INSTRUCTION-CONTEXT 'FORCE-DISPATCH-OR-BYTE)))
                (SETQ NEW 'FORCE-BYTE)
                (GO N1)))
        (CONS-LAP-BARF (LIST INSTRUCTION-CONTEXT NEW) 'CONFLICTING-CONTEXT 'DATA)
        (RETURN NIL)
  N1    (SETQ INSTRUCTION-CONTEXT NEW)
        (RETURN T)
))
